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