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