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