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
   9 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
  10 use Carp 'carp';
  11
  12 has schema => (
  13   isa      => 'DBIx::Class::Schema',
  14   is       => 'ro',
  15   required => 1,
  16   handles => [qw( schema_version )],
  17 );
  18
  19 has storage => (
  20   isa        => 'DBIx::Class::Storage',
  21   is         => 'ro',
  22   lazy_build => 1,
  23 );
  24
  25 method _build_storage {
  26   my $s = $self->schema->storage;
  27   $s->_determine_driver;
  28   $s
  29 }
  30
  31 has sqltargs => (
  32   isa => 'HashRef',
  33   is  => 'ro',
  34   default => sub { {} },
  35 );
  36 has upgrade_directory => (
  37   isa      => 'Str',
  38   is       => 'ro',
  39   required => 1,
  40   default  => 'sql',
  41 );
  42
  43 has databases => (
  44   coerce  => 1,
  45   isa     => 'DBIx::Class::DeploymentHandler::Databases',
  46   is      => 'ro',
  47   default => sub { [qw( MySQL SQLite PostgreSQL )] },
  48 );
  49
  50 has _filedata => (
  51   isa => 'ArrayRef[Str]',
  52   is  => 'rw',
  53 );
  54
  55 # these two methods should go away once we switch to
  56 # DBIx::Migration::Directories
  57 method _ddl_schema_filename($type, $version, $dir) {
  58   my $filename = ref $self->schema;
  59   $filename =~ s/::/-/g;
  60
  61   $filename = File::Spec->catfile(
  62     $dir, "$filename-schema-$version-$type.sql"
  63   );
  64
  65   return $filename;
  66 }
  67
  68 method _ddl_schema_diff_filename($type, $versions, $dir) {
  69   my $filename = ref $self->schema;
  70   $filename =~ s/::/-/g;
  71
  72   $filename = File::Spec->catfile(
  73     $dir, "$filename-diff-" . join( q(-), @{$versions} ) . "-$type.sql"
  74   );
  75
  76   return $filename;
  77 }
  78
  79 method _deployment_statements {
  80   my $dir      = $self->upgrade_directory;
  81   my $schema   = $self->schema;
  82   my $type     = $self->storage->sqlt_type;
  83   my $sqltargs = $self->sqltargs;
  84   my $version  = $self->schema_version;
  85
  86   my $filename = $self->_ddl_schema_filename($type, $version, $dir);
  87   if(-f $filename) {
  88       my $file;
  89       open $file, q(<), $filename
  90         or carp "Can't open $filename ($!)";
  91       my @rows = <$file>;
  92       close $file;
  93       return join '', @rows;
  94   }
  95
  96   # sources needs to be a parser arg, but for simplicty allow at top level
  97   # coming in
  98   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
  99       if exists $sqltargs->{sources};
 100
 101   my $tr = SQL::Translator->new(
 102     producer => "SQL::Translator::Producer::${type}",
 103     %$sqltargs,
 104     parser => 'SQL::Translator::Parser::DBIx::Class',
 105     data => $schema,
 106   );
 107
 108   my @ret;
 109   my $wa = wantarray;
 110   if ($wa) {
 111     @ret = $tr->translate;
 112   }
 113   else {
 114     $ret[0] = $tr->translate;
 115   }
 116
 117   $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
 118     unless (@ret && defined $ret[0]);
 119
 120   return $wa ? @ret : $ret[0];
 121 }
 122
 123 sub _deploy {
 124   my $self = shift;
 125   my $storage  = $self->storage;
 126
 127   my $deploy = sub {
 128     my $line = shift;
 129     return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/);
 130     $storage->_query_start($line);
 131     try {
 132       # do a dbh_do cycle here, as we need some error checking in
 133       # place (even though we will ignore errors)
 134       $storage->dbh_do (sub { $_[1]->do($line) });
 135     }
 136     catch {
 137       carp "$_ (running '${line}')"
 138     }
 139     $storage->_query_end($line);
 140   };
 141   my @statements = $self->_deployment_statements();
 142   if (@statements > 1) {
 143     foreach my $statement (@statements) {
 144       $deploy->( $statement );
 145     }
 146   }
 147   elsif (@statements == 1) {
 148     foreach my $line ( split(";\n", $statements[0])) {
 149       $deploy->( $line );
 150     }
 151   }
 152 }
 153
 154 sub prepare_install {
 155   my $self = shift;
 156   my $schema    = $self->schema;
 157   my $databases = $self->databases;
 158   my $dir       = $self->upgrade_directory;
 159   my $sqltargs  = $self->sqltargs;
 160   my $version = $schema->schema_version;
 161
 162   unless( -d $dir ) {
 163     carp "Upgrade directory $dir does not exist, using ./\n";
 164     $dir = './';
 165   }
 166
 167
 168   my $sqlt = SQL::Translator->new({
 169     add_drop_table          => 1,
 170     ignore_constraint_names => 1,
 171     ignore_index_names      => 1,
 172     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 173     %{$sqltargs || {}}
 174   });
 175
 176   my $sqlt_schema = $sqlt->translate({ data => $schema })
 177     or $self->throw_exception ($sqlt->error);
 178
 179   foreach my $db (@$databases) {
 180     $sqlt->reset;
 181     $sqlt->{schema} = $sqlt_schema;
 182     $sqlt->producer($db);
 183
 184     my $filename = $self->_ddl_schema_filename($db, $version, $dir);
 185     if (-e $filename ) {
 186       carp "Overwriting existing DDL file - $filename";
 187       unlink $filename;
 188     }
 189
 190     my $output = $sqlt->translate;
 191     if(!$output) {
 192       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 193       next;
 194     }
 195     my $file;
 196     unless( open $file, q(>), $filename ) {
 197       $self->throw_exception("Can't open $filename for writing ($!)");
 198       next;
 199     }
 200     print {$file} $output;
 201     close $file;
 202   }
 203 }
 204
 205 sub prepare_update {
 206   my ($self, $from_version, $to_version, $version_set) = @_;
 207
 208   $from_version ||= $self->db_version;
 209   $to_version   ||= $self->schema_version;
 210
 211   # for updates prepared automatically (rob's stuff)
 212   # one would want to explicitly set $version_set to
 213   # [$to_version]
 214   $version_set  ||= [$from_version, $to_version];
 215   my $schema    = $self->schema;
 216   my $databases = $self->databases;
 217   my $dir       = $self->upgrade_directory;
 218   my $sqltargs  = $self->sqltargs;
 219
 220   unless( -d $dir ) {
 221     carp "Upgrade directory $dir does not exist, using ./\n";
 222     $dir = "./";
 223   }
 224
 225   my $schema_version = $schema->schema_version;
 226
 227   $sqltargs = {
 228     add_drop_table => 1,
 229     ignore_constraint_names => 1,
 230     ignore_index_names => 1,
 231     %{$sqltargs}
 232   };
 233
 234   my $sqlt = SQL::Translator->new( $sqltargs );
 235
 236   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 237   my $sqlt_schema = $sqlt->translate({ data => $schema })
 238     or $self->throw_exception ($sqlt->error);
 239
 240   foreach my $db (@$databases) {
 241     $sqlt->reset;
 242     $sqlt->{schema} = $sqlt_schema;
 243     $sqlt->producer($db);
 244
 245     my $prefilename = $self->_ddl_schema_filename($db, $from_version, $dir);
 246     unless(-e $prefilename) {
 247       carp("No previous schema file found ($prefilename)");
 248       next;
 249     }
 250
 251     my $diff_file = $self->_ddl_schema_diff_filename($db, $version_set, $dir );
 252     if(-e $diff_file) {
 253       carp("Overwriting existing diff file - $diff_file");
 254       unlink $diff_file;
 255     }
 256
 257     my $source_schema;
 258     {
 259       my $t = SQL::Translator->new({
 260          %{$sqltargs},
 261          debug => 0,
 262          trace => 0,
 263       });
 264
 265       $t->parser( $db ) # could this really throw an exception?
 266         or $self->throw_exception ($t->error);
 267
 268       my $out = $t->translate( $prefilename )
 269         or $self->throw_exception ($t->error);
 270
 271       $source_schema = $t->schema;
 272
 273       $source_schema->name( $prefilename )
 274         unless  $source_schema->name;
 275     }
 276
 277     # The "new" style of producers have sane normalization and can support
 278     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 279     # And we have to diff parsed SQL against parsed SQL.
 280     my $dest_schema = $sqlt_schema;
 281
 282     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 283       my $t = SQL::Translator->new({
 284          %{$sqltargs},
 285          debug => 0,
 286          trace => 0,
 287       });
 288
 289       $t->parser( $db ) # could this really throw an exception?
 290         or $self->throw_exception ($t->error);
 291
 292       my $filename = $self->_ddl_schema_filename($db, $to_version, $dir);
 293       my $out = $t->translate( $filename )
 294         or $self->throw_exception ($t->error);
 295
 296       $dest_schema = $t->schema;
 297
 298       $dest_schema->name( $filename )
 299         unless $dest_schema->name;
 300     }
 301
 302     my $diff = SQL::Translator::Diff::schema_diff(
 303        $source_schema, $db,
 304        $dest_schema,   $db,
 305        $sqltargs
 306     );
 307     my $file;
 308     unless(open $file, q(>), $diff_file) {
 309       $self->throw_exception("Can't write to $diff_file ($!)");
 310       next;
 311     }
 312     print {$file} $diff;
 313     close $file;
 314   }
 315 }
 316
 317 method _read_sql_file($file) {
 318   return unless $file;
 319
 320   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
 321   my @data = split /\n/, join '', <$fh>;
 322   close $fh;
 323
 324   @data = grep {
 325     $_ &&
 326     !/^--/ &&
 327     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
 328   } split /;/,
 329     join '', @data;
 330
 331   return \@data;
 332 }
 333
 334 sub _upgrade_single_step {
 335   my $self = shift;
 336   my @version_set = @{ shift @_ };
 337   my $upgrade_file = $self->_ddl_schema_diff_filename(
 338     $self->storage->sqlt_type,
 339     \@version_set,
 340     $self->upgrade_directory,
 341   );
 342
 343   unless (-f $upgrade_file) {
 344     # croak?
 345     carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 346     return;
 347   }
 348
 349   $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 350   $self->schema->txn_do(sub { $self->_do_upgrade });
 351 }
 352
 353 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
 354
 355 method _run_upgrade($stm) {
 356   return unless $self->_filedata;
 357   my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 358
 359   for (@statements) {
 360     $self->storage->debugobj->query_start($_) if $self->storage->debug;
 361     $self->_apply_statement($_);
 362     $self->storage->debugobj->query_end($_) if $self->storage->debug;
 363   }
 364 }
 365
 366 method _apply_statement($statement) {
 367   # croak?
 368   $self->storage->dbh->do($_) or carp "SQL was: $_"
 369 }
 370
 371 __PACKAGE__->meta->make_immutable;
 372
 373 1;
 374
 375 __END__
 376
 377 vim: ts=2 sw=2 expandtab