lib/DBIx/Class/DeploymentHandler/SqltDeployMethod.pm

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