factor out filesystem interactions

[dbsrgits/DBIx-Class-DeploymentHandler.git] / lib / DBIx / Class / DeploymentHandler / Filesystem.pm

package DBIx::Class::DeploymentHandler::Filesystem;

use Moose;
use Method::Signatures::Simple;
use File::Path 'mkpath';
use File::Spec::Functions;
use Try::Tiny;

has script_directory => (
  isa      => 'Str',
  is       => 'ro',
  required => 1,
  default  => 'sql',
);

has ignore_ddl => ( is => 'ro' );


method _ddl_protoschema_produce_filename($version) {
  my $dirname = catfile( $self->script_directory, '_source', 'deploy',  $version );
  mkpath($dirname) unless -d $dirname;

  return catfile( $dirname, '001-auto.yml' );
}


method _ddl_protoschema_deploy_consume_filenames($version) {
  my $base_dir = $self->script_directory;

  my $dir = catfile( $base_dir, '_source', 'deploy', $version);
  return [] unless -d $dir;

  opendir my($dh), $dir;
  my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
  closedir $dh;

  return [@files{sort keys %files}]
}

method _ddl_protoschema_upgrade_consume_filenames($versions) {
  my $base_dir = $self->script_directory;

  my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});

  return [] unless -d $dir;

  opendir my($dh), $dir;
  my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
  closedir $dh;

  return [@files{sort keys %files}]
}

method _ddl_protoschema_downgrade_consume_filenames($versions) {
  my $base_dir = $self->script_directory;

  my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});

  return [] unless -d $dir;

  opendir my($dh), $dir;
  my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
  closedir $dh;

  return [@files{sort keys %files}]
}



method __ddl_consume_with_prefix($type, $versions, $prefix) {
  my $base_dir = $self->script_directory;

  my $main    = catfile( $base_dir, $type      );
  my $common  =
    catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );

  my $common_any  =
    catfile( $base_dir, '_common', $prefix, '_any' );

  my $dir;
  if (-d $main) {
    $dir = catfile($main, $prefix, join q(-), @{$versions})
  } else {
    if ($self->ignore_ddl) {
      return []
    } else {
      die "$main does not exist; please write/generate some SQL"
    }
  }
  my $dir_any = catfile($main, $prefix, '_any');

  my %files;
  try {
     opendir my($dh), $dir;
     %files =
       map { $_ => "$dir/$_" }
       grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
       readdir $dh;
     closedir $dh;
  } catch {
    die $_ unless $self->ignore_ddl;
  };
  for my $dirname (grep { -d $_ } $common, $common_any, $dir_any) {
    opendir my($dh), $dirname;
    for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($dirname,$_) } readdir $dh) {
      unless ($files{$filename}) {
        $files{$filename} = catfile($dirname,$filename);
      }
    }
    closedir $dh;
  }

  return [@files{sort keys %files}]
}

method _ddl_initialize_consume_filenames($type, $version) {
  $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
}

method _ddl_schema_consume_filenames($type, $version) {
  $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
}

method _ddl_schema_upgrade_consume_filenames($type, $versions) {
  $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
}

method _ddl_schema_downgrade_consume_filenames($type, $versions) {
  $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
}


method _ddl_schema_produce_filename($type, $version) {
  my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
  mkpath($dirname) unless -d $dirname;

  return catfile( $dirname, '001-auto.sql' );
}

method _ddl_schema_upgrade_produce_filename($type, $versions) {
  my $dir = $self->script_directory;

  my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
  mkpath($dirname) unless -d $dirname;

  return catfile( $dirname, '001-auto.sql' );
}

method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
  my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
  mkpath($dirname) unless -d $dirname;

  return catfile( $dirname, '001-auto.sql');
}


method _read_sql_file($file) {
  return unless $file;

  open my $fh, '<', $file;
  my @data = split /;\n/, join '', <$fh>;
  close $fh;

  @data = grep {
    $_ && # remove blank lines
    !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
  } map {
    s/^\s+//; s/\s+$//; # trim whitespace
    join '', grep { !/^--/ } split /\n/ # remove comments
  } @data;

  return \@data;
}

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


method _write_data_string($filename, $data) {
  open my $file, q(>), $filename;
  print {$file} $data;
  close $file;
}


method _write_data_list($filename, $data) {
  open my $file, q(>), $filename;
  print {$file} join ";\n", @$data;
  close $file;
}

__PACKAGE__->meta->make_immutable;

1;