lib/DBIx/Class/DeploymentHandler.pm

   1 package DBIx::Class::DeploymentHandler;
   2
   3 use Moose;
   4 use Method::Signatures::Simple;
   5 require DBIx::Class::Schema; # loaded for type constraint
   6 require DBIx::Class::Storage; # loaded for type constraint
   7 use Carp 'carp';
   8
   9 has schema => (
  10    isa      => 'DBIx::Class::Schema',
  11    is       => 'ro',
  12    required => 1,
  13    handles => [qw{schema_version}],
  14 );
  15
  16 has upgrade_directory => (
  17    isa      => 'Str',
  18    is       => 'ro',
  19    required => 1,
  20    default  => 'sql',
  21 );
  22
  23 has backup_directory => (
  24    isa => 'Str',
  25    is  => 'ro',
  26 );
  27
  28 has storage => (
  29    isa        => 'DBIx::Class::Storage',
  30    is         => 'ro',
  31    lazy_build => 1,
  32 );
  33
  34 has _filedata => (
  35    is => 'ro',
  36 );
  37
  38 has do_backup => (
  39    isa     => 'Bool',
  40    is      => 'ro',
  41    default => undef,
  42 );
  43
  44 has do_diff_on_init => (
  45    isa     => 'Bool',
  46    is      => 'ro',
  47    default => undef,
  48 );
  49
  50 method _build_storage {
  51    return $self->schema->storage;
  52 }
  53
  54 method install($new_version) {
  55   # must be called on a fresh database
  56   if ($self->get_db_version) {
  57     carp 'Install not possible as versions table already exists in database';
  58   }
  59
  60   # default to current version if none passed
  61   $new_version ||= $self->schema_version();
  62
  63   if ($new_version) {
  64     # create versions table and version row
  65     $self->{vschema}->deploy;
  66     $self->_set_db_version({ version => $new_version });
  67   }
  68 }
  69
  70 method deploy {
  71   $self->next::method(@_);
  72   $self->install();
  73 }
  74
  75 sub create_upgrade_path {
  76   ## override this method
  77 }
  78
  79 sub ordered_schema_versions {
  80   ## override this method
  81 }
  82
  83 method upgrade {
  84   my $db_version = $self->get_db_version();
  85
  86   # db unversioned
  87   unless ($db_version) {
  88       carp 'Upgrade not possible as database is unversioned. Please call install first.';
  89       return;
  90   }
  91
  92   # db and schema at same version. do nothing
  93   if ( $db_version eq $self->schema_version ) {
  94       carp "Upgrade not necessary\n";
  95       return;
  96   }
  97
  98   my @version_list = $self->ordered_schema_versions;
  99
 100   # if nothing returned then we preload with min/max
 101   @version_list = ( $db_version, $self->schema_version )
 102     unless ( scalar(@version_list) );
 103
 104   # catch the case of someone returning an arrayref
 105   @version_list = @{ $version_list[0] }
 106     if ( ref( $version_list[0] ) eq 'ARRAY' );
 107
 108   # remove all versions in list above the required version
 109   while ( scalar(@version_list)
 110       && ( $version_list[-1] ne $self->schema_version ) )
 111   {
 112       pop @version_list;
 113   }
 114
 115   # remove all versions in list below the current version
 116   while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) {
 117       shift @version_list;
 118   }
 119
 120   # check we have an appropriate list of versions
 121   if ( scalar(@version_list) < 2 ) {
 122       die;
 123   }
 124
 125   # do sets of upgrade
 126   while ( scalar(@version_list) >= 2 ) {
 127       $self->upgrade_single_step( $version_list[0], $version_list[1] );
 128       shift @version_list;
 129   }
 130 }
 131
 132 method upgrade_single_step($db_version, $target_version) {
 133   # db and schema at same version. do nothing
 134   if ($db_version eq $target_version) {
 135     carp "Upgrade not necessary\n";
 136     return;
 137   }
 138
 139   # strangely the first time this is called can
 140   # differ to subsequent times. so we call it
 141   # here to be sure.
 142   # XXX - just fix it
 143   $self->storage->sqlt_type;
 144
 145   my $upgrade_file = $self->ddl_filename(
 146                                          $self->storage->sqlt_type,
 147                                          $target_version,
 148                                          $self->upgrade_directory,
 149                                          $db_version,
 150                                         );
 151
 152   $self->create_upgrade_path({ upgrade_file => $upgrade_file });
 153
 154   unless (-f $upgrade_file) {
 155     carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 156     return;
 157   }
 158
 159   carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
 160
 161   # backup if necessary then apply upgrade
 162   $self->_filedata($self->_read_sql_file($upgrade_file));
 163   $self->backup() if($self->do_backup);
 164   $self->txn_do(sub { $self->do_upgrade() });
 165
 166   # set row in dbix_class_schema_versions table
 167   $self->_set_db_version({version => $target_version});
 168 }
 169
 170 method do_upgrade {
 171   # just run all the commands (including inserts) in order
 172   $self->run_upgrade(qr/.*?/);
 173 }
 174
 175 method run_upgrade($stm) {
 176     return unless ($self->_filedata);
 177     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 178     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 179
 180     for (@statements) {
 181         $self->storage->debugobj->query_start($_) if $self->storage->debug;
 182         $self->apply_statement($_);
 183         $self->storage->debugobj->query_end($_) if $self->storage->debug;
 184     }
 185
 186     return 1;
 187 }
 188
 189 method apply_statement($statement) {
 190     $self->storage->dbh->do($_) or carp "SQL was: $_";
 191 }
 192
 193 method get_db_version {
 194     my $vtable = $self->schema->resultset('VersionResult');
 195     my $version = $vtable->search(undef, {
 196       order_by => { -desc => 'installed' },
 197       rows => 1
 198     })->get_column('version')->next || 0;
 199     return $version;
 200 }
 201
 202 method backup {
 203     ## Make each ::DBI::Foo do this
 204     $self->storage->backup($self->backup_directory());
 205 }
 206
 207 method connection  {
 208   $self->next::method(@_);
 209   $self->_on_connect($_[3]);
 210   return $self;
 211 }
 212
 213 method _on_connect($args) {
 214   $args ||= {};
 215
 216   $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
 217   my $vtable = $self->{vschema}->resultset('Table');
 218
 219   # useful when connecting from scripts etc
 220   return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
 221
 222   # check for legacy versions table and move to new if exists
 223   my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
 224   unless ($self->_source_exists($vtable)) {
 225     my $vtable_compat = $vschema_compat->resultset('TableCompat');
 226     if ($self->_source_exists($vtable_compat)) {
 227       $self->{vschema}->deploy;
 228       map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
 229       $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
 230     }
 231   }
 232
 233   my $pversion = $self->get_db_version();
 234
 235   if($pversion eq $self->schema_version)
 236     {
 237 #         carp "This version is already installed\n";
 238         return 1;
 239     }
 240
 241   if(!$pversion)
 242     {
 243         carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
 244         return 1;
 245     }
 246
 247   carp "Versions out of sync. This is " . $self->schema_version .
 248     ", your database contains version $pversion, please call upgrade on your Schema.\n";
 249 }
 250
 251 sub _create_db_to_schema_diff {
 252   my $self = shift;
 253
 254   my %driver_to_db_map = (
 255     'mysql' => 'MySQL'
 256   );
 257
 258   my $db = $driver_to_db_map{$self->storage->dbh->{Driver}{Name}};
 259   unless ($db) {
 260     print "Sorry, this is an unsupported DB\n";
 261     return;
 262   }
 263
 264   $self->throw_exception($self->storage->_sqlt_version_error)
 265     unless $self->storage->_sqlt_version_ok;
 266
 267   my $db_tr = SQL::Translator->new({
 268     add_drop_table => 1,
 269     parser         => 'DBI',
 270     parser_args    => { dbh  => $self->storage->dbh },
 271     producer       => $db,
 272   });
 273
 274   my $dbic_tr = SQL::Translator->new({
 275     parser   => 'SQL::Translator::Parser::DBIx::Class',
 276     data     => $self,
 277     producer => $db,
 278   });
 279
 280   $db_tr->schema->name('db_schema');
 281   $dbic_tr->schema->name('dbic_schema');
 282
 283   # is this really necessary?
 284   foreach my $tr ($db_tr, $dbic_tr) {
 285     my $data = $tr->data;
 286     $tr->parser->($tr, $$data);
 287   }
 288
 289   my $diff = SQL::Translator::Diff::schema_diff(
 290     $db_tr->schema,   $db,
 291     $dbic_tr->schema, $db, {
 292       ignore_constraint_names => 1,
 293       ignore_index_names      => 1,
 294       caseopt                 => 1,
 295     }
 296   );
 297
 298   my $filename = $self->ddl_filename(
 299     $db,
 300     $self->schema_version,
 301     $self->upgrade_directory,
 302     'PRE',
 303   );
 304
 305   open my $file, '>', $filename
 306     or $self->throw_exception("Can't open $filename for writing ($!)");
 307   print {$file} $diff;
 308   close $file;
 309
 310   carp "WARNING: There may be differences between your DB and your DBIC schema.\n" .
 311        "Please review and if necessary run the SQL in $filename to sync your DB.\n";
 312 }
 313
 314 method _read_sql_file($file) {
 315   return unless $file;
 316
 317   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
 318   my @data = split /\n/, join '', <$fh>;
 319   close $fh;
 320
 321   @data = grep {
 322     $_ &&
 323     !/^--/ &&
 324     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
 325   } split /;/,
 326     join '', @data;
 327
 328   return \@data;
 329 }
 330
 331 method _source_exists($rs) {
 332   my $c = eval {
 333     $rs->search({ 1, 0 })->count;
 334   };
 335   return 0 if $@ || !defined $c;
 336
 337   return 1;
 338 }
 339
 340 1;