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 has txn_wrap => (
  59   is => 'ro',
  60   isa => 'Bool',
  61   default => 1,
  62 );
  63
  64 method __ddl_consume_with_prefix($type, $versions, $prefix) {
  65   my $base_dir = $self->upgrade_directory;
  66
  67   my $main    = File::Spec->catfile( $base_dir, $type                         );
  68   my $generic = File::Spec->catfile( $base_dir, '_generic'                    );
  69   my $common =  File::Spec->catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
  70
  71   my $dir;
  72   if (-d $main) {
  73     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  74   } elsif (-d $generic) {
  75     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  76   } else {
  77     die 'PREPARE TO SQL'
  78   }
  79
  80   opendir my($dh), $dir;
  81   my %files = map { $_ => "$dir/$_" } grep { /\.sql$/ && -f "$dir/$_" } readdir($dh);
  82   closedir $dh;
  83
  84   if (-d $common) {
  85     opendir my($dh), $common;
  86     for my $filename (grep { /\.sql$/ && -f "$common/$_" } readdir($dh)) {
  87       unless ($files{$filename}) {
  88         $files{$filename} = "$common/$_";
  89       }
  90     }
  91     closedir $dh;
  92   }
  93
  94   return [@files{sort keys %files}]
  95 }
  96
  97 method _ddl_schema_consume_filenames($type, $version) {
  98   $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
  99 }
 100
 101 method _ddl_schema_produce_filename($type, $version) {
 102   my $base_dir = $self->upgrade_directory;
 103   my $dirname = File::Spec->catfile(
 104     $base_dir, $type, 'schema', $version
 105   );
 106   File::Path::mkpath($dirname) unless -d $dirname;
 107
 108   return File::Spec->catfile(
 109     $dirname, '001-auto.sql'
 110   );
 111 }
 112
 113 method _ddl_schema_up_consume_filenames($type, $versions) {
 114   $self->__ddl_consume_with_prefix($type, $versions, 'up')
 115 }
 116
 117 method _ddl_schema_down_consume_filenames($type, $versions) {
 118   $self->__ddl_consume_with_prefix($type, $versions, 'down')
 119 }
 120
 121 method _ddl_schema_up_produce_filename($type, $versions) {
 122   my $dir = $self->upgrade_directory;
 123
 124   my $dirname = File::Spec->catfile(
 125     $dir, $type, 'up', join( q(-), @{$versions} )
 126   );
 127   File::Path::mkpath($dirname) unless -d $dirname;
 128
 129   return File::Spec->catfile(
 130     $dirname, '001-auto.sql'
 131   );
 132 }
 133
 134 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
 135   my $dirname = File::Spec->catfile(
 136     $dir, $type, 'down', join( q(-), @{$versions} )
 137   );
 138   File::Path::mkpath($dirname) unless -d $dirname;
 139
 140   return File::Spec->catfile(
 141     $dirname, '001-auto.sql'
 142   );
 143 }
 144
 145 method _deployment_statements {
 146   my $dir      = $self->upgrade_directory;
 147   my $schema   = $self->schema;
 148   my $type     = $self->storage->sqlt_type;
 149   my $sqltargs = $self->sqltargs;
 150   my $version  = $self->schema_version;
 151
 152   my @filenames = @{$self->_ddl_schema_consume_filenames($type, $version)};
 153
 154   for my $filename (@filenames) {
 155     if(-f $filename) {
 156         my $file;
 157         open $file, q(<), $filename
 158           or carp "Can't open $filename ($!)";
 159         my @rows = <$file>;
 160         close $file;
 161         return join '', @rows;
 162     }
 163   }
 164
 165   # sources needs to be a parser arg, but for simplicty allow at top level
 166   # coming in
 167   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
 168       if exists $sqltargs->{sources};
 169
 170   my $tr = SQL::Translator->new(
 171     producer => "SQL::Translator::Producer::${type}",
 172     %$sqltargs,
 173     parser => 'SQL::Translator::Parser::DBIx::Class',
 174     data => $schema,
 175   );
 176
 177   my $ret = $tr->translate;
 178
 179   $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
 180     unless defined $ret;
 181
 182   return $ret;
 183 }
 184
 185 sub _deploy {
 186   my $self = shift;
 187   my $storage  = $self->storage;
 188
 189   my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 190
 191   foreach my $line ( split /;\n/, $self->_deployment_statements ) {
 192     $line = join '', grep { !/^--/ } split /\n/, $line;
 193     next if !$line || $line =~ /^BEGIN TRANSACTION|^COMMIT|^\s+$/;
 194     $storage->_query_start($line);
 195     try {
 196       # do a dbh_do cycle here, as we need some error checking in
 197       # place (even though we will ignore errors)
 198       $storage->dbh_do (sub { $_[1]->do($line) });
 199     }
 200     catch {
 201       carp "$_ (running '${line}')"
 202     }
 203     $storage->_query_end($line);
 204   }
 205
 206   $guard->commit if $self->txn_wrap;
 207 }
 208
 209 sub prepare_install {
 210   my $self = shift;
 211   my $schema    = $self->schema;
 212   my $databases = $self->databases;
 213   my $dir       = $self->upgrade_directory;
 214   my $sqltargs  = $self->sqltargs;
 215   my $version = $schema->schema_version;
 216
 217   unless( -d $dir ) {
 218     carp "Upgrade directory $dir does not exist, using ./\n";
 219     $dir = './';
 220   }
 221
 222
 223   my $sqlt = SQL::Translator->new({
 224     add_drop_table          => 1,
 225     ignore_constraint_names => 1,
 226     ignore_index_names      => 1,
 227     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 228     %{$sqltargs || {}}
 229   });
 230
 231   my $sqlt_schema = $sqlt->translate({ data => $schema })
 232     or $self->throw_exception ($sqlt->error);
 233
 234   foreach my $db (@$databases) {
 235     $sqlt->reset;
 236     $sqlt->{schema} = $sqlt_schema;
 237     $sqlt->producer($db);
 238
 239     my $filename = $self->_ddl_schema_produce_filename($db, $version, $dir);
 240     if (-e $filename ) {
 241       carp "Overwriting existing DDL file - $filename";
 242       unlink $filename;
 243     }
 244
 245     my $output = $sqlt->translate;
 246     if(!$output) {
 247       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 248       next;
 249     }
 250     my $file;
 251     unless( open $file, q(>), $filename ) {
 252       $self->throw_exception("Can't open $filename for writing ($!)");
 253       next;
 254     }
 255     print {$file} $output;
 256     close $file;
 257   }
 258 }
 259
 260 sub prepare_upgrade {
 261   my ($self, $from_version, $to_version, $version_set) = @_;
 262
 263   $from_version ||= $self->db_version;
 264   $to_version   ||= $self->schema_version;
 265
 266   # for updates prepared automatically (rob's stuff)
 267   # one would want to explicitly set $version_set to
 268   # [$to_version]
 269   $version_set  ||= [$from_version, $to_version];
 270
 271   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
 272 }
 273
 274 sub prepare_downgrade {
 275   my ($self, $from_version, $to_version, $version_set) = @_;
 276
 277   $from_version ||= $self->db_version;
 278   $to_version   ||= $self->schema_version;
 279
 280   # for updates prepared automatically (rob's stuff)
 281   # one would want to explicitly set $version_set to
 282   # [$to_version]
 283   $version_set  ||= [$from_version, $to_version];
 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 $self->throw_exception ($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 $self->throw_exception ($t->error);
 336
 337       my $out = $t->translate( $prefilename )
 338         or $self->throw_exception ($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 $self->throw_exception ($t->error);
 360
 361       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 362       my $out = $t->translate( $filename )
 363         or $self->throw_exception ($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     my $file;
 377     unless(open $file, q(>), $diff_file) {
 378       $self->throw_exception("Can't write to $diff_file ($!)");
 379       next;
 380     }
 381     print {$file} $diff;
 382     close $file;
 383   }
 384 }
 385
 386 method _read_sql_file($file) {
 387   return unless $file;
 388
 389   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
 390   my @data = split /\n/, join '', <$fh>;
 391   close $fh;
 392
 393   @data = grep {
 394     $_ &&
 395     !/^--/ &&
 396     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
 397   } split /;/,
 398     join '', @data;
 399
 400   return \@data;
 401 }
 402
 403 # these are exactly the same for now
 404 sub _downgrade_single_step {
 405   my $self = shift;
 406   my @version_set = @{ shift @_ };
 407   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 408     $self->storage->sqlt_type,
 409     \@version_set,
 410   )};
 411
 412   for my $upgrade_file (@upgrade_files) {
 413     unless (-f $upgrade_file) {
 414       # croak?
 415       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 416       return;
 417     }
 418
 419     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 420
 421     my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 422     $self->_do_upgrade;
 423     $guard->commit if $self->txn_wrap;
 424   }
 425 }
 426
 427 sub _upgrade_single_step {
 428   my $self = shift;
 429   my @version_set = @{ shift @_ };
 430   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 431     $self->storage->sqlt_type,
 432     \@version_set,
 433   )};
 434
 435   for my $upgrade_file (@upgrade_files) {
 436     unless (-f $upgrade_file) {
 437       # croak?
 438       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 439       return;
 440     }
 441
 442     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 443     my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 444     $self->_do_upgrade;
 445     $guard->commit if $self->txn_wrap;
 446   }
 447 }
 448
 449 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
 450
 451 method _run_upgrade($stm) {
 452   return unless $self->_filedata;
 453   my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 454
 455   for (@statements) {
 456     $self->storage->debugobj->query_start($_) if $self->storage->debug;
 457     $self->_apply_statement($_);
 458     $self->storage->debugobj->query_end($_) if $self->storage->debug;
 459   }
 460 }
 461
 462 method _apply_statement($statement) {
 463   # croak?
 464   $self->storage->dbh->do($_) or carp "SQL was: $_"
 465 }
 466
 467 1;
 468
 469 __END__
 470
 471 vim: ts=2 sw=2 expandtab