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_in_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_in_filenames($type, $version) {
  92   $self->__ddl_in_with_prefix($type, [ $version ], 'schema')
  93 }
  94
  95 method _ddl_schema_out_filename($type, $version, $dir) {
  96   my $dirname = File::Spec->catfile(
  97     $dir, $type, 'schema', $version
  98   );
  99   File::Path::mkpath($dirname) unless -d $dirname;
 100
 101   return File::Spec->catfile(
 102     $dirname, '001-auto.sql'
 103   );
 104 }
 105
 106 method _ddl_schema_up_in_filenames($type, $versions, $dir) {
 107   $self->__ddl_in_with_prefix($type, $versions, 'up')
 108 }
 109
 110 method _ddl_schema_down_in_filenames($type, $versions, $dir) {
 111   $self->__ddl_in_with_prefix($type, $versions, 'down')
 112 }
 113
 114 method _ddl_schema_up_out_filename($type, $versions, $dir) {
 115   my $dirname = File::Spec->catfile(
 116     $dir, $type, 'up', join( q(-), @{$versions} )
 117   );
 118   File::Path::mkpath($dirname) unless -d $dirname;
 119
 120   return File::Spec->catfile(
 121     $dirname, '001-auto.sql'
 122   );
 123 }
 124
 125 method _ddl_schema_down_out_filename($type, $versions, $dir) {
 126   my $dirname = File::Spec->catfile(
 127     $dir, $type, 'down', 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 _deployment_statements {
 137   my $dir      = $self->upgrade_directory;
 138   my $schema   = $self->schema;
 139   my $type     = $self->storage->sqlt_type;
 140   my $sqltargs = $self->sqltargs;
 141   my $version  = $self->schema_version;
 142
 143   my @filenames = @{$self->_ddl_schema_in_filenames($type, $version)};
 144
 145   for my $filename (@filenames) {
 146     if(-f $filename) {
 147         my $file;
 148         open $file, q(<), $filename
 149           or carp "Can't open $filename ($!)";
 150         my @rows = <$file>;
 151         close $file;
 152         return join '', @rows;
 153     }
 154   }
 155
 156   # sources needs to be a parser arg, but for simplicty allow at top level
 157   # coming in
 158   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
 159       if exists $sqltargs->{sources};
 160
 161   my $tr = SQL::Translator->new(
 162     producer => "SQL::Translator::Producer::${type}",
 163     %$sqltargs,
 164     parser => 'SQL::Translator::Parser::DBIx::Class',
 165     data => $schema,
 166   );
 167
 168   my @ret;
 169   my $wa = wantarray;
 170   if ($wa) {
 171     @ret = $tr->translate;
 172   }
 173   else {
 174     $ret[0] = $tr->translate;
 175   }
 176
 177   $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
 178     unless (@ret && defined $ret[0]);
 179
 180   return $wa ? @ret : $ret[0];
 181 }
 182
 183 sub _deploy {
 184   my $self = shift;
 185   my $storage  = $self->storage;
 186
 187   my $deploy = sub {
 188     my $line = shift;
 189     return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/);
 190     $storage->_query_start($line);
 191     try {
 192       # do a dbh_do cycle here, as we need some error checking in
 193       # place (even though we will ignore errors)
 194       $storage->dbh_do (sub { $_[1]->do($line) });
 195     }
 196     catch {
 197       carp "$_ (running '${line}')"
 198     }
 199     $storage->_query_end($line);
 200   };
 201   my @statements = $self->_deployment_statements();
 202   if (@statements > 1) {
 203     foreach my $statement (@statements) {
 204       $deploy->( $statement );
 205     }
 206   }
 207   elsif (@statements == 1) {
 208     foreach my $line ( split(";\n", $statements[0])) {
 209       $deploy->( $line );
 210     }
 211   }
 212 }
 213
 214 sub prepare_install {
 215   my $self = shift;
 216   my $schema    = $self->schema;
 217   my $databases = $self->databases;
 218   my $dir       = $self->upgrade_directory;
 219   my $sqltargs  = $self->sqltargs;
 220   my $version = $schema->schema_version;
 221
 222   unless( -d $dir ) {
 223     carp "Upgrade directory $dir does not exist, using ./\n";
 224     $dir = './';
 225   }
 226
 227
 228   my $sqlt = SQL::Translator->new({
 229     add_drop_table          => 1,
 230     ignore_constraint_names => 1,
 231     ignore_index_names      => 1,
 232     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 233     %{$sqltargs || {}}
 234   });
 235
 236   my $sqlt_schema = $sqlt->translate({ data => $schema })
 237     or $self->throw_exception ($sqlt->error);
 238
 239   foreach my $db (@$databases) {
 240     $sqlt->reset;
 241     $sqlt->{schema} = $sqlt_schema;
 242     $sqlt->producer($db);
 243
 244     my $filename = $self->_ddl_schema_out_filename($db, $version, $dir);
 245     if (-e $filename ) {
 246       carp "Overwriting existing DDL file - $filename";
 247       unlink $filename;
 248     }
 249
 250     my $output = $sqlt->translate;
 251     if(!$output) {
 252       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 253       next;
 254     }
 255     my $file;
 256     unless( open $file, q(>), $filename ) {
 257       $self->throw_exception("Can't open $filename for writing ($!)");
 258       next;
 259     }
 260     print {$file} $output;
 261     close $file;
 262   }
 263 }
 264
 265 sub prepare_upgrade {
 266   my ($self, $from_version, $to_version, $version_set) = @_;
 267
 268   $from_version ||= $self->db_version;
 269   $to_version   ||= $self->schema_version;
 270
 271   # for updates prepared automatically (rob's stuff)
 272   # one would want to explicitly set $version_set to
 273   # [$to_version]
 274   $version_set  ||= [$from_version, $to_version];
 275   my $schema    = $self->schema;
 276   my $databases = $self->databases;
 277   my $dir       = $self->upgrade_directory;
 278   my $sqltargs  = $self->sqltargs;
 279
 280   unless( -d $dir ) {
 281     carp "Upgrade directory $dir does not exist, using ./\n";
 282     $dir = "./";
 283   }
 284
 285   my $schema_version = $schema->schema_version;
 286
 287   $sqltargs = {
 288     add_drop_table => 1,
 289     ignore_constraint_names => 1,
 290     ignore_index_names => 1,
 291     %{$sqltargs}
 292   };
 293
 294   my $sqlt = SQL::Translator->new( $sqltargs );
 295
 296   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 297   my $sqlt_schema = $sqlt->translate({ data => $schema })
 298     or $self->throw_exception ($sqlt->error);
 299
 300   foreach my $db (@$databases) {
 301     $sqlt->reset;
 302     $sqlt->{schema} = $sqlt_schema;
 303     $sqlt->producer($db);
 304
 305     my $prefilename = $self->_ddl_schema_out_filename($db, $from_version, $dir);
 306     unless(-e $prefilename) {
 307       carp("No previous schema file found ($prefilename)");
 308       next;
 309     }
 310
 311     my $diff_file = $self->_ddl_schema_up_out_filename($db, $version_set, $dir );
 312     if(-e $diff_file) {
 313       carp("Overwriting existing up-diff file - $diff_file");
 314       unlink $diff_file;
 315     }
 316
 317     my $source_schema;
 318     {
 319       my $t = SQL::Translator->new({
 320          %{$sqltargs},
 321          debug => 0,
 322          trace => 0,
 323       });
 324
 325       $t->parser( $db ) # could this really throw an exception?
 326         or $self->throw_exception ($t->error);
 327
 328       my $out = $t->translate( $prefilename )
 329         or $self->throw_exception ($t->error);
 330
 331       $source_schema = $t->schema;
 332
 333       $source_schema->name( $prefilename )
 334         unless  $source_schema->name;
 335     }
 336
 337     # The "new" style of producers have sane normalization and can support
 338     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 339     # And we have to diff parsed SQL against parsed SQL.
 340     my $dest_schema = $sqlt_schema;
 341
 342     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 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 $filename = $self->_ddl_schema_out_filename($db, $to_version, $dir);
 353       my $out = $t->translate( $filename )
 354         or $self->throw_exception ($t->error);
 355
 356       $dest_schema = $t->schema;
 357
 358       $dest_schema->name( $filename )
 359         unless $dest_schema->name;
 360     }
 361
 362     my $diff = SQL::Translator::Diff::schema_diff(
 363        $source_schema, $db,
 364        $dest_schema,   $db,
 365        $sqltargs
 366     );
 367     my $file;
 368     unless(open $file, q(>), $diff_file) {
 369       $self->throw_exception("Can't write to $diff_file ($!)");
 370       next;
 371     }
 372     print {$file} $diff;
 373     close $file;
 374   }
 375 }
 376
 377 method _read_sql_file($file) {
 378   return unless $file;
 379
 380   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
 381   my @data = split /\n/, join '', <$fh>;
 382   close $fh;
 383
 384   @data = grep {
 385     $_ &&
 386     !/^--/ &&
 387     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
 388   } split /;/,
 389     join '', @data;
 390
 391   return \@data;
 392 }
 393
 394 sub _upgrade_single_step {
 395   my $self = shift;
 396   my @version_set = @{ shift @_ };
 397   my @upgrade_files = @{$self->_ddl_schema_up_in_filenames(
 398     $self->storage->sqlt_type,
 399     \@version_set,
 400   )};
 401
 402   for my $upgrade_file (@upgrade_files) {
 403     unless (-f $upgrade_file) {
 404       # croak?
 405       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 406       return;
 407     }
 408
 409     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 410     $self->schema->txn_do(sub { $self->_do_upgrade });
 411   }
 412 }
 413
 414 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
 415
 416 method _run_upgrade($stm) {
 417   return unless $self->_filedata;
 418   my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 419
 420   for (@statements) {
 421     $self->storage->debugobj->query_start($_) if $self->storage->debug;
 422     $self->_apply_statement($_);
 423     $self->storage->debugobj->query_end($_) if $self->storage->debug;
 424   }
 425 }
 426
 427 method _apply_statement($statement) {
 428   # croak?
 429   $self->storage->dbh->do($_) or carp "SQL was: $_"
 430 }
 431
 432 1;
 433
 434 __END__
 435
 436 vim: ts=2 sw=2 expandtab