view release on metacpan or  search on metacpan

lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm  view on Meta::CPAN

   return preserve_context { $code->() } after => sub { $guard->commit };
}

sub _run_sql_and_perl {
  my ($self, $filenames, $sql_to_run, $versions) = @_;
  my @files   = @{$filenames};
  $self->txn_do(sub {
     $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;

     my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
     FILENAME:
     for my $filename (map file($_), @files) {
       if ($self->ignore_ddl && $filename->basename =~ /^[^-]*-auto.*\.sql$/) {
         next FILENAME
       } elsif ($filename =~ /\.sql$/) {
          $sql .= $self->_run_sql($filename)
       } elsif ( $filename =~ /\.pl$/ ) {
          $self->_run_perl($filename, $versions)
       } else {
         croak "A file ($filename) got to deploy that wasn't sql or perl!";
       }
     }

     return $sql;
  });
}

sub deploy {
  my $self = shift;
  my $version = (shift @_ || {})->{version} || $self->schema_version;
  log_info { "deploying version $version" };
  my $sqlt_type = $self->storage->sqlt_type;
  my $sql;
  my $sqltargs = $self->sql_translator_args;
  if ($self->ignore_ddl) {
     $sql = $self->_sql_from_yaml($sqltargs,
       '_ddl_protoschema_deploy_consume_filenames', $sqlt_type
     );
  }
  return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
    $sqlt_type,
    $version,
  ), $sql, [$version]);
}

sub initialize {
  my $self         = shift;
  my $args         = shift;
  my $version      = $args->{version}      || $self->schema_version;
  log_info { "initializing version $version" };
  my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;

  my @files = @{$self->_ddl_initialize_consume_filenames(
    $storage_type,
    $version,
  )};

  for my $filename (@files) {
    # We ignore sql for now (till I figure out what to do with it)
    if ( $filename =~ /^(.+)\.pl$/ ) {
      my $filedata = do { local( @ARGV, $/ ) = $filename; <> };

      no warnings 'redefine';
      my $fn = eval "$filedata";
      use warnings;

      if ($@) {
        croak "$filename failed to compile: $@";
      } elsif (ref $fn eq 'CODE') {
        $fn->()
      } else {
        croak "$filename should define an anonymous sub but it didn't!";
      }
    } else {
      croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
    }
  }
}

sub _sqldiff_from_yaml {
  my ($self, $from_version, $to_version, $db, $direction) = @_;
  my $dir       = $self->script_directory;
  my $sqltargs = {
    add_drop_table => 0,
    ignore_constraint_names => 1,
    ignore_index_names => 1,
    %{$self->sql_translator_args}
  };

  my $source_schema;
  {
    my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);

    # should probably be a croak
    carp("No previous schema file found ($prefilename)")
       unless -e $prefilename;

    my $t = SQL::Translator->new({
       %{$sqltargs},
       debug => 0,
       trace => 0,
       parser => 'SQL::Translator::Parser::YAML',
    });

    my $out = $t->translate( $prefilename )
      or croak($t->error);

    $source_schema = $t->schema;

    $source_schema->name( $prefilename )
      unless  $source_schema->name;
  }

  my $dest_schema;
  {
    my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);

    # should probably be a croak
    carp("No next schema file found ($filename)")
       unless -e $filename;

lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm  view on Meta::CPAN

     $self->$rs_install_file(
      $self->storage->sqlt_type,
      $version,
    )
  ];
  $self->_run_sql_and_perl($files, [], [$version]);
}

sub prepare_resultsource_install {
  my $self = shift;
  my $source = (shift @_)->{result_source};
  log_info { 'preparing install for resultsource ' . $source->source_name };

  my $install_filename = $self->_resultsource_install_filename($source->source_name);
  my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
  $self->prepare_protoschema({
      parser_args => { sources => [$source->source_name], }
  }, $proto_filename);
  $self->_prepare_install({}, $proto_filename, $install_filename);
}

sub prepare_deploy {
  log_info { 'preparing deploy' };
  my $self = shift;
  $self->prepare_protoschema({
      # Exclude version table so that it gets installed separately
      parser_args => {
         sources => [
            sort { $a cmp $b }
            grep { $_ ne $self->version_source }
            $self->schema->sources
         ],
      }
  }, '_ddl_protoschema_produce_filename');
  $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
}

sub prepare_upgrade {
  my ($self, $args) = @_;
  log_info {
     "preparing upgrade from $args->{from_version} to $args->{to_version}"
  };
  $self->_prepare_changegrade(
    $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
  );
}

sub prepare_downgrade {
  my ($self, $args) = @_;
  log_info {
     "preparing downgrade from $args->{from_version} to $args->{to_version}"
  };
  $self->_prepare_changegrade(
    $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
  );
}

sub _coderefs_per_files {
  my ($self, $files) = @_;
  no warnings 'redefine';
  [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
}

sub _prepare_changegrade {
  my ($self, $from_version, $to_version, $version_set, $direction) = @_;
  my $schema    = $self->schema;
  my $databases = $self->databases;
  my $dir       = $self->script_directory;

  my $schema_version = $self->schema_version;
  my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
  foreach my $db (@$databases) {
    my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
    if(-e $diff_file) {
      if ($self->force_overwrite) {
         carp("Overwriting existing $direction-diff file - $diff_file");
         unlink $diff_file;
      } else {
         die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it"
      }
    }

    open my $file, q(>), $diff_file;
    binmode $file;
    print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
    close $file;
  }
}

sub _read_sql_file {
  my ($self, $file)  = @_;
  return unless $file;

   local $/ = undef;  #sluuuuuurp

  open my $fh, '<', $file;
  return [ $self->_split_sql_chunk( <$fh> ) ];
}

sub downgrade_single_step {
  my $self = shift;
  my $version_set = (shift @_)->{version_set};
  Dlog_info { "downgrade_single_step'ing $_" } $version_set;

  my $sqlt_type = $self->storage->sqlt_type;
  my $sql_to_run;
  if ($self->ignore_ddl) {
     $sql_to_run = $self->_sqldiff_from_yaml(
       $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
     );
  }
  my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
    $sqlt_type,
    $version_set,
  ), $sql_to_run, $version_set);

  return ['', $sql];
}

sub upgrade_single_step {
  my $self = shift;