File Coverage

blib/lib/DBIx/Class/Schema/Diff/SchemaData.pm

Criterion	Covered	Total	%
statement	118	124	95.1
branch	28	38	73.6
condition	10	12	83.3
subroutine	27	30	90.0
pod	4	7	57.1
total	187	211	88.6

package DBIx::Class::Schema::Diff::SchemaData;
use strict;
use warnings;

# ABSTRACT: Data representation of schema for diffing

use Moo;
with 'DBIx::Class::Schema::Diff::Role::Common';

use Types::Standard qw(:all);
use Module::Runtime;
use Scalar::Util qw(blessed);
use Path::Class qw(file);
use JSON;
use Clone 'clone';
use Digest::SHA1;

use Data::Dumper;
use Data::Dumper::Concise;

has 'schema', is => 'ro', isa => Maybe[InstanceOf[
  'DBIx::Class::Schema'
]], coerce => \&_coerce_schema, default => sub {undef};

has 'data', is => 'ro', lazy => 1, default => sub {
  my $self = shift;

  die "You must supply a schema or an existing data packet"
    unless ($self->schema);

  return $self->_gen_data( $self->schema );

}, isa => HashRef, coerce => \&_coerce_deep_unsafe_refs;


sub BUILD {
  my $self = shift;

  # initialize:
  $self->data;
}

sub sources {
  my $self = shift;
  return sort keys %{ $self->data->{sources} || {} };
}

sub source {
  my ($self, $name) = @_;
  return $self->data->{sources}{$name};
}

sub dump_json {
  my $self = shift;
  JSON::to_json( $self->data => { pretty => 1 });
}

sub dump_json_file {
  my ($self, $path) = @_;
  die "Filename required" unless ($path);
  my $file = file($path)->absolute;

  die "Target file '$file' already exists." if (-e $file);

  my $out_fh;
  open $out_fh, '>', $file or die "Could not open $file: $!";
  print $out_fh JSON::to_json( $self->data, { pretty => 1 });
  close $out_fh;
  return -f $file ? 1 : 0;
}


sub _gen_data {
  my ($self, $schema) = @_;

  my $data = {
    schema_class => (blessed $schema),
    sources => {
      map {
        my $Source = $schema->source($_);
        $_ => {

          columns => {
            map {
              $_ => $Source->column_info($_)
            } $Source->columns
          },

          relationships => {
            map {
              $_ => $Source->relationship_info($_)
            } $Source->relationships
          },

          constraints => {
            map {
              $_ => { columns => [$Source->unique_constraint_columns($_)] }
            } $Source->unique_constraint_names
          },

          table_name => $Source->from,

          isa => mro::get_linear_isa( $schema->class( $Source->source_name ) ),

        }
      } $schema->sources
    }
  };

  return $self->_localize_deep_namespace_strings($data,$data->{schema_class});
}


sub _coerce_schema {
  my ($v) = @_;
  return $v if (!$v || ref $v);

  # Its a class name:
  Module::Runtime::require_module($v);
  return $v->can('connect') ? $v->connect('dbi:SQLite::memory:','','') : $v;
}


sub _coerce_deep_unsafe_refs {
  my ($v) = @_;
  my $rt = ref($v) or return $v;

  if($rt eq 'HASH') {
    return { map { $_ => &_coerce_deep_unsafe_refs($v->{$_}) } keys %$v };
  }
  elsif($rt eq 'ARRAY') {
    return [ map { &_coerce_deep_unsafe_refs($_) } @$v ];
  }
  elsif($rt eq 'CODE') {
    # TODO: we don't have to do this, we could let it through
    # to be stringified, but for now, we're not trying to compare
    # CodeRef contents
    return 'sub { "DUMMY" }';
  }
  else {
    # For all other refs, stringify them with Dumper. These will still
    # be just as useful for diff/compare. This makes them safe for JSON, etc
    my $str = Dumper($v);
    # strip newlines:
    $str =~ s/\r?\n//g;
    # normalize whitespace:
    $str =~ s/\s+/ /g;
    return $str;
  }
}

sub _localize_deep_namespace_strings {
  my ($self, $v, $ns) = @_;
  my $rt = ref($v);
  if($rt) {
    if($rt eq 'HASH') {
      return { map {
        $_ => $self->_localize_deep_namespace_strings($v->{$_},$ns)
      } keys %$v };
    }
    elsif($rt eq 'ARRAY') {
      return [ map {
        $self->_localize_deep_namespace_strings($_,$ns)
      } @$v ];
    }
    else {
      return $v;
    }
  }
  else {
    # swap the namespace prefix string for literal '{schema_class}':
    $v =~ s/^${ns}/\{schema_class\}/ if($v && $ns && $v ne $ns);
    return $v;
  }
}


sub prune {
  my ($self,@keywords) = @_;
  die "must supply at least 1 prune keyword" unless (scalar(@keywords) > 0);

  my $data = clone( $self->data );

  my @meths = map {
    my $meth = join('_','__prune',$_);
    $self->can($meth) or die "Bad prune keyword '$_' (no such method '$meth')";
    $meth
  } @keywords;

  $self->$_($data) for (@meths);

  __PACKAGE__->new({ data => $data })
}


sub __prune_isa {
  my ($self, $data) = @_;
  $self->_prune_whole_source_key('isa',$data)
}

sub __prune_constraints {
  my ($self, $data) = @_;
  $self->_prune_whole_source_key('constraints',$data)
}

sub __prune_relationships {
  my ($self, $data) = @_;
  $self->_prune_whole_source_key('relationships',$data)
}

sub __prune_columns {
  my ($self, $data) = @_;
  $self->_prune_whole_source_key('columns',$data)
}


sub __prune_private_col_attrs {
  my ($self, $data) = @_;

  for my $rsrcData (values %{ $data->{sources} }) {
    if(my $columns = $rsrcData->{columns}) {
      for my $attrs (values %$columns) {
        # delete all keys starting with underscore '_'
        $_ =~ /^_/ and delete $attrs->{$_} for (keys %$attrs);
      }
    }
  }

  $data
}


sub _prune_whole_source_key {
  my ($self, $key, $data) = @_;

  for my $rsrcData (values %{ $data->{sources} }) {
    delete $rsrcData->{$key} if exists $rsrcData->{$key}
  }

  $data
}


sub fingerprint {
  my $self = shift;
  my $sum = Digest::SHA1->new->add( $self->_string_for_signature )->hexdigest;
  join('-', 'schemsum', substr($sum,0,15) )
}


# So far this is the only thing I could find to produce a consistent string value across all
# Travis tested perls (5.10,5.12,5.14,5.16,5.18,5.20,5.22,5.24,5.26)
sub _string_for_signature {
  my $self = shift;

  local $Data::Dumper::Maxdepth = 0;
  Data::Dumper->new([ $self->data->{sources} ])
   ->Purity(0)
   ->Terse(1)
   ->Indent(0)
   ->Useqq(1)
   ->Sortkeys(1)
   ->Dump()
}


1;


__END__