lib/DBIx/Class/DeploymentHandler/Filesystem.pm

   1 package DBIx::Class::DeploymentHandler::Filesystem;
   2
   3 use Moose;
   4 use Method::Signatures::Simple;
   5 use File::Path 'mkpath';
   6 use File::Spec::Functions;
   7 use Try::Tiny;
   8
   9 has script_directory => (
  10   isa      => 'Str',
  11   is       => 'ro',
  12   required => 1,
  13   default  => 'sql',
  14 );
  15
  16 has ignore_ddl => ( is => 'ro' );
  17
  18
  19 method _ddl_protoschema_produce_filename($version) {
  20   my $dirname = catfile( $self->script_directory, '_source', 'deploy',  $version );
  21   mkpath($dirname) unless -d $dirname;
  22
  23   return catfile( $dirname, '001-auto.yml' );
  24 }
  25
  26
  27 method _ddl_protoschema_deploy_consume_filenames($version) {
  28   my $base_dir = $self->script_directory;
  29
  30   my $dir = catfile( $base_dir, '_source', 'deploy', $version);
  31   return [] unless -d $dir;
  32
  33   opendir my($dh), $dir;
  34   my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
  35   closedir $dh;
  36
  37   return [@files{sort keys %files}]
  38 }
  39
  40 method _ddl_protoschema_upgrade_consume_filenames($versions) {
  41   my $base_dir = $self->script_directory;
  42
  43   my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
  44
  45   return [] unless -d $dir;
  46
  47   opendir my($dh), $dir;
  48   my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
  49   closedir $dh;
  50
  51   return [@files{sort keys %files}]
  52 }
  53
  54 method _ddl_protoschema_downgrade_consume_filenames($versions) {
  55   my $base_dir = $self->script_directory;
  56
  57   my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
  58
  59   return [] unless -d $dir;
  60
  61   opendir my($dh), $dir;
  62   my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
  63   closedir $dh;
  64
  65   return [@files{sort keys %files}]
  66 }
  67
  68
  69
  70 method __ddl_consume_with_prefix($type, $versions, $prefix) {
  71   my $base_dir = $self->script_directory;
  72
  73   my $main    = catfile( $base_dir, $type      );
  74   my $common  =
  75     catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
  76
  77   my $common_any  =
  78     catfile( $base_dir, '_common', $prefix, '_any' );
  79
  80   my $dir;
  81   if (-d $main) {
  82     $dir = catfile($main, $prefix, join q(-), @{$versions})
  83   } else {
  84     if ($self->ignore_ddl) {
  85       return []
  86     } else {
  87       die "$main does not exist; please write/generate some SQL"
  88     }
  89   }
  90   my $dir_any = catfile($main, $prefix, '_any');
  91
  92   my %files;
  93   try {
  94      opendir my($dh), $dir;
  95      %files =
  96        map { $_ => "$dir/$_" }
  97        grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
  98        readdir $dh;
  99      closedir $dh;
 100   } catch {
 101     die $_ unless $self->ignore_ddl;
 102   };
 103   for my $dirname (grep { -d $_ } $common, $common_any, $dir_any) {
 104     opendir my($dh), $dirname;
 105     for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($dirname,$_) } readdir $dh) {
 106       unless ($files{$filename}) {
 107         $files{$filename} = catfile($dirname,$filename);
 108       }
 109     }
 110     closedir $dh;
 111   }
 112
 113   return [@files{sort keys %files}]
 114 }
 115
 116 method _ddl_initialize_consume_filenames($type, $version) {
 117   $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
 118 }
 119
 120 method _ddl_schema_consume_filenames($type, $version) {
 121   $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
 122 }
 123
 124 method _ddl_schema_upgrade_consume_filenames($type, $versions) {
 125   $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
 126 }
 127
 128 method _ddl_schema_downgrade_consume_filenames($type, $versions) {
 129   $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
 130 }
 131
 132
 133 method _ddl_schema_produce_filename($type, $version) {
 134   my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
 135   mkpath($dirname) unless -d $dirname;
 136
 137   return catfile( $dirname, '001-auto.sql' );
 138 }
 139
 140 method _ddl_schema_upgrade_produce_filename($type, $versions) {
 141   my $dir = $self->script_directory;
 142
 143   my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
 144   mkpath($dirname) unless -d $dirname;
 145
 146   return catfile( $dirname, '001-auto.sql' );
 147 }
 148
 149 method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
 150   my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
 151   mkpath($dirname) unless -d $dirname;
 152
 153   return catfile( $dirname, '001-auto.sql');
 154 }
 155
 156
 157 method _read_sql_file($file) {
 158   return unless $file;
 159
 160   open my $fh, '<', $file;
 161   my @data = split /;\n/, join '', <$fh>;
 162   close $fh;
 163
 164   @data = grep {
 165     $_ && # remove blank lines
 166     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
 167   } map {
 168     s/^\s+//; s/\s+$//; # trim whitespace
 169     join '', grep { !/^--/ } split /\n/ # remove comments
 170   } @data;
 171
 172   return \@data;
 173 }
 174
 175 method _coderefs_per_files($files) {
 176   no warnings 'redefine';
 177   [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
 178 }
 179
 180
 181 method _write_data_string($filename, $data) {
 182   open my $file, q(>), $filename;
 183   print {$file} $data;
 184   close $file;
 185 }
 186
 187
 188 method _write_data_list($filename, $data) {
 189   open my $file, q(>), $filename;
 190   print {$file} join ";\n", @$data;
 191   close $file;
 192 }
 193
 194 __PACKAGE__->meta->make_immutable;
 195
 196 1;