factor out filesystem interactions

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

diff --git a/lib/DBIx/Class/DeploymentHandler/Filesystem.pm b/lib/DBIx/Class/DeploymentHandler/Filesystem.pm
new file mode 100644 (file)
index 0000000..2df9c13
--- /dev/null
+++ b/lib/DBIx/Class/DeploymentHandler/Filesystem.pm
@@ -0,0 +1,196 @@
+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;