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 use DBIx::Class::DeploymentHandler::Types;
  11
  12
  13 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
  14
  15 use Carp 'carp';
  16
  17 has schema => (
  18   isa      => 'DBIx::Class::Schema',
  19   is       => 'ro',
  20   required => 1,
  21   handles => [qw( schema_version )],
  22 );
  23
  24 has storage => (
  25   isa        => 'DBIx::Class::Storage',
  26   is         => 'ro',
  27   lazy_build => 1,
  28 );
  29
  30 method _build_storage {
  31   my $s = $self->schema->storage;
  32   $s->_determine_driver;
  33   $s
  34 }
  35
  36 has sqltargs => (
  37   isa => 'HashRef',
  38   is  => 'ro',
  39   default => sub { {} },
  40 );
  41 has upgrade_directory => (
  42   isa      => 'Str',
  43   is       => 'ro',
  44   required => 1,
  45   default  => 'sql',
  46 );
  47
  48 has databases => (
  49   coerce  => 1,
  50   isa     => 'DBIx::Class::DeploymentHandler::Databases',
  51   is      => 'ro',
  52   default => sub { [qw( MySQL SQLite PostgreSQL )] },
  53 );
  54
  55 has _filedata => (
  56   isa => 'ArrayRef[Str]',
  57   is  => 'rw',
  58 );
  59
  60 has txn_wrap => (
  61   is => 'ro',
  62   isa => 'Bool',
  63   default => 1,
  64 );
  65
  66 method __ddl_consume_with_prefix($type, $versions, $prefix) {
  67   my $base_dir = $self->upgrade_directory;
  68
  69   my $main    = File::Spec->catfile( $base_dir, $type                         );
  70   my $generic = File::Spec->catfile( $base_dir, '_generic'                    );
  71   my $common =  File::Spec->catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
  72
  73   my $dir;
  74   if (-d $main) {
  75     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  76   } elsif (-d $generic) {
  77     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  78   } else {
  79     die 'PREPARE TO SQL'
  80   }
  81
  82   opendir my($dh), $dir;
  83   my %files = map { $_ => "$dir/$_" } grep { /\.sql$/ && -f "$dir/$_" } readdir($dh);
  84   closedir $dh;
  85
  86   if (-d $common) {
  87     opendir my($dh), $common;
  88     for my $filename (grep { /\.sql$/ && -f "$common/$_" } readdir($dh)) {
  89       unless ($files{$filename}) {
  90         $files{$filename} = "$common/$_";
  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 $base_dir = $self->upgrade_directory;
 105   my $dirname = File::Spec->catfile(
 106     $base_dir, $type, 'schema', $version
 107   );
 108   File::Path::mkpath($dirname) unless -d $dirname;
 109
 110   return File::Spec->catfile(
 111     $dirname, '001-auto.sql'
 112   );
 113 }
 114
 115 method _ddl_schema_up_consume_filenames($type, $versions) {
 116   $self->__ddl_consume_with_prefix($type, $versions, 'up')
 117 }
 118
 119 method _ddl_schema_down_consume_filenames($type, $versions) {
 120   $self->__ddl_consume_with_prefix($type, $versions, 'down')
 121 }
 122
 123 method _ddl_schema_up_produce_filename($type, $versions) {
 124   my $dir = $self->upgrade_directory;
 125
 126   my $dirname = File::Spec->catfile(
 127     $dir, $type, 'up', join( q(-), @{$versions} )
 128   );
 129   File::Path::mkpath($dirname) unless -d $dirname;
 130
 131   return File::Spec->catfile(
 132     $dirname, '001-auto.sql'
 133   );
 134 }
 135
 136 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
 137   my $dirname = File::Spec->catfile(
 138     $dir, $type, 'down', join( q(-), @{$versions} )
 139   );
 140   File::Path::mkpath($dirname) unless -d $dirname;
 141
 142   return File::Spec->catfile(
 143     $dirname, '001-auto.sql'
 144   );
 145 }
 146
 147 sub _deploy {
 148   my $self = shift;
 149   my $storage  = $self->storage;
 150
 151   my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 152
 153   my @sql = map @{$self->_read_sql_file($_)}, @{$self->_ddl_schema_consume_filenames(
 154       $self->storage->sqlt_type,
 155       $self->schema_version
 156     )};
 157
 158   foreach my $line (@sql) {
 159     $storage->_query_start($line);
 160     try {
 161       # do a dbh_do cycle here, as we need some error checking in
 162       # place (even though we will ignore errors)
 163       $storage->dbh_do (sub { $_[1]->do($line) });
 164     }
 165     catch {
 166       carp "$_ (running '${line}')"
 167     }
 168     $storage->_query_end($line);
 169   }
 170
 171   $guard->commit if $self->txn_wrap;
 172   return join "\n", @sql;
 173 }
 174
 175 sub prepare_install {
 176   my $self = shift;
 177   my $schema    = $self->schema;
 178   my $databases = $self->databases;
 179   my $dir       = $self->upgrade_directory;
 180   my $sqltargs  = $self->sqltargs;
 181   my $version = $schema->schema_version;
 182
 183   my $sqlt = SQL::Translator->new({
 184     add_drop_table          => 1,
 185     ignore_constraint_names => 1,
 186     ignore_index_names      => 1,
 187     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 188     %{$sqltargs}
 189   });
 190
 191   my $sqlt_schema = $sqlt->translate( data => $schema )
 192     or $self->throw_exception($sqlt->error);
 193
 194   foreach my $db (@$databases) {
 195     $sqlt->reset;
 196     $sqlt->{schema} = $sqlt_schema;
 197     $sqlt->producer($db);
 198
 199     my $filename = $self->_ddl_schema_produce_filename($db, $version, $dir);
 200     if (-e $filename ) {
 201       carp "Overwriting existing DDL file - $filename";
 202       unlink $filename;
 203     }
 204
 205     my $output = $sqlt->translate;
 206     if(!$output) {
 207       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 208       next;
 209     }
 210     my $file;
 211     unless( open $file, q(>), $filename ) {
 212       $self->throw_exception("Can't open $filename for writing ($!)");
 213       next;
 214     }
 215     print {$file} $output;
 216     close $file;
 217   }
 218 }
 219
 220 sub prepare_upgrade {
 221   my ($self, $from_version, $to_version, $version_set) = @_;
 222
 223   $from_version ||= $self->db_version;
 224   $to_version   ||= $self->schema_version;
 225
 226   # for updates prepared automatically (rob's stuff)
 227   # one would want to explicitly set $version_set to
 228   # [$to_version]
 229   $version_set  ||= [$from_version, $to_version];
 230
 231   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
 232 }
 233
 234 sub prepare_downgrade {
 235   my ($self, $from_version, $to_version, $version_set) = @_;
 236
 237   $from_version ||= $self->db_version;
 238   $to_version   ||= $self->schema_version;
 239
 240   # for updates prepared automatically (rob's stuff)
 241   # one would want to explicitly set $version_set to
 242   # [$to_version]
 243   $version_set  ||= [$from_version, $to_version];
 244
 245   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
 246 }
 247
 248 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
 249   my $schema    = $self->schema;
 250   my $databases = $self->databases;
 251   my $dir       = $self->upgrade_directory;
 252   my $sqltargs  = $self->sqltargs;
 253
 254   my $schema_version = $schema->schema_version;
 255
 256   $sqltargs = {
 257     add_drop_table => 1,
 258     ignore_constraint_names => 1,
 259     ignore_index_names => 1,
 260     %{$sqltargs}
 261   };
 262
 263   my $sqlt = SQL::Translator->new( $sqltargs );
 264
 265   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 266   my $sqlt_schema = $sqlt->translate( data => $schema )
 267     or $self->throw_exception ($sqlt->error);
 268
 269   foreach my $db (@$databases) {
 270     $sqlt->reset;
 271     $sqlt->{schema} = $sqlt_schema;
 272     $sqlt->producer($db);
 273
 274     my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
 275     unless(-e $prefilename) {
 276       carp("No previous schema file found ($prefilename)");
 277       next;
 278     }
 279     my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 280     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 281     if(-e $diff_file) {
 282       carp("Overwriting existing $direction-diff file - $diff_file");
 283       unlink $diff_file;
 284     }
 285
 286     my $source_schema;
 287     {
 288       my $t = SQL::Translator->new({
 289          %{$sqltargs},
 290          debug => 0,
 291          trace => 0,
 292       });
 293
 294       $t->parser( $db ) # could this really throw an exception?
 295         or $self->throw_exception ($t->error);
 296
 297       my $out = $t->translate( $prefilename )
 298         or $self->throw_exception ($t->error);
 299
 300       $source_schema = $t->schema;
 301
 302       $source_schema->name( $prefilename )
 303         unless  $source_schema->name;
 304     }
 305
 306     # The "new" style of producers have sane normalization and can support
 307     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 308     # And we have to diff parsed SQL against parsed SQL.
 309     my $dest_schema = $sqlt_schema;
 310
 311     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 312       my $t = SQL::Translator->new({
 313          %{$sqltargs},
 314          debug => 0,
 315          trace => 0,
 316       });
 317
 318       $t->parser( $db ) # could this really throw an exception?
 319         or $self->throw_exception ($t->error);
 320
 321       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 322       my $out = $t->translate( $filename )
 323         or $self->throw_exception ($t->error);
 324
 325       $dest_schema = $t->schema;
 326
 327       $dest_schema->name( $filename )
 328         unless $dest_schema->name;
 329     }
 330
 331     my $diff = SQL::Translator::Diff::schema_diff(
 332        $source_schema, $db,
 333        $dest_schema,   $db,
 334        $sqltargs
 335     );
 336     my $file;
 337     unless(open $file, q(>), $diff_file) {
 338       $self->throw_exception("Can't write to $diff_file ($!)");
 339       next;
 340     }
 341     print {$file} $diff;
 342     close $file;
 343   }
 344 }
 345
 346 method _read_sql_file($file) {
 347   return unless $file;
 348
 349   open my $fh, '<', $file or carp("Can't open sql file, $file ($!)");
 350   my @data = split /;\n/, join '', <$fh>;
 351   close $fh;
 352
 353   @data = grep {
 354     $_ && # remove blank lines
 355     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
 356   } map {
 357     s/^\s+//; s/\s+$//; # trim whitespace
 358     join '', grep { !/^--/ } split /\n/ # remove comments
 359   } @data;
 360
 361   return \@data;
 362 }
 363
 364 # these are exactly the same for now
 365 sub _downgrade_single_step {
 366   my $self = shift;
 367   my @version_set = @{ shift @_ };
 368   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 369     $self->storage->sqlt_type,
 370     \@version_set,
 371   )};
 372
 373   for my $upgrade_file (@upgrade_files) {
 374     unless (-f $upgrade_file) {
 375       # croak?
 376       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 377       return;
 378     }
 379
 380     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 381
 382     my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 383     $self->_do_upgrade;
 384     $guard->commit if $self->txn_wrap;
 385   }
 386 }
 387
 388 sub _upgrade_single_step {
 389   my $self = shift;
 390   my @version_set = @{ shift @_ };
 391   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 392     $self->storage->sqlt_type,
 393     \@version_set,
 394   )};
 395
 396   for my $upgrade_file (@upgrade_files) {
 397     unless (-f $upgrade_file) {
 398       # croak?
 399       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 400       return;
 401     }
 402
 403     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 404     my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 405     $self->_do_upgrade;
 406     $guard->commit if $self->txn_wrap;
 407   }
 408 }
 409
 410 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
 411
 412 method _run_upgrade($stm) {
 413   return unless $self->_filedata;
 414   my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 415
 416   for (@statements) {
 417     $self->storage->debugobj->query_start($_) if $self->storage->debug;
 418     $self->_apply_statement($_);
 419     $self->storage->debugobj->query_end($_) if $self->storage->debug;
 420   }
 421 }
 422
 423 method _apply_statement($statement) {
 424   # croak?
 425   $self->storage->dbh->do($_) or carp "SQL was: $_"
 426 }
 427
 428 1;
 429
 430 __END__
 431
 432 vim: ts=2 sw=2 expandtab