File Coverage

blib/lib/DBIx/Class/EasyConf/YAML.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package DBIx::Class::EasyConf::YAML;

use 5.008008;
use strict;

use YAML;
our $VERSION = '0.11';
our $VERBOSE = undef;

sub configure {
  my ($package, $fh) = @_;

  my %args = map { lc $_ => 1 } @ARGV;
  $VERBOSE    = $args{verbose} ? 1 : undef;
  my $config  = $args{configuration} ? 1 : undef;

  {
    no strict 'refs';
    $fh ||=  *{"${package}::DATA"};
  }

  my $yaml = do { local $/; <$fh> };
  my $data = YAML::Load($yaml);

  _set_table         ($package, $data);
  _set_columns       ($package, $data);
  _set_pk            ($package, $data);
  _set_unique        ($package, $data);
  _set_relationships ($package, $data);

  print_configuration($package) if $config;
}


sub _set_table {
  my ($package, $data) = @_;
  my $table = $data->{table}
    or die "Cannot configure $package: table not specified.\n";
  $package->table($table);
}

sub _set_pk {
  my ($package, $data) = @_;
  my $pk = $data->{primary_key}
    or die "Cannot configure $package: primary key not specified.\n";
  $package->set_primary_key(ref $pk eq 'ARRAY' ? @$pk : $pk);
}

sub _set_columns {
  my ($package, $data) = @_;
  die "Cannot configure $package: columns not properly specified.\n"
    unless ref $data->{columns} eq 'HASH';
  my $columns = $data->{columns};
  $package->add_columns(%{ $columns });
}

sub _set_unique {
  my ($package, $data) = @_;
  return unless ref $data->{unique} eq 'HASH';
  for my $name (keys %{ $data->{unique} }) {
    my $spec = $data->{unique}->{$name};
    my $cols = ref $spec eq 'ARRAY' ? $spec : [ $spec ];
    $package->add_unique_constraint($name => $cols);
  }
}

sub _set_relationships {
  my ($package, $data) = @_;
  return unless ref $data->{relationships} eq 'ARRAY';
  for my $relation (@{ $data->{relationships} }) {
    my ($relation, $value) = each %{ $relation };
    my ($type, $class, $condition, $attrs) = @{ $value };
    $class = resolve_relative_class($class, $package)
      unless $type eq 'many_to_many';
    $package->$type($relation, $class, $condition, $attrs);

    if ($VERBOSE) {
      my %relationships = map { $_ => 1 } $package->relationships;
      my $ok = exists $relationships{$relation} ? 1 : undef;
      my $space_one = " " x (50 - length $package);
      my $space_two = " " x (20 - length $relation);
      print STDERR
	($ok ? "RELATION OK:" : "RELATION FAIL: "),
	  "$package $space_one $relation $space_two $type\n",
	    "\t$package->$type($relation, $class, $condition)\n\n";
    }
  }
}

sub resolve_relative_class {
  my ($class, $package) = @_;
  return $class if $class =~ /::/; # fully qualified already.
  (my $new_package = $package) =~ s/::[^:]+$/::$class/;
  return $new_package;
}

sub print_configuration {
  my $package = shift;
  local $\ = "\n";
  print "Table: ", $package->table;
  print "Primary Key: ", join ", " => $package->primary_columns;

  print "Columns: ";
  for my $col ($package->columns) {
    my %info = %{ $package->column_info($col) };
    print "\t$col:";
    print "\t\t$_ => $info{$_}" for sort keys %info;
  }

  print "Relationships:";
  for my $rel ($package->relationships) {
    my %info = %{ $package->relationship_info($rel) };
    print "\t$rel:";
    for my $key (sort keys %info) {
      if (ref $info{$key}) {
	print "\t\t$key:";
	print "\t\t\t$_ => $info{$key}->{$_}" for sort keys %{ $info{$key} };
      }
      else {
	print "\t\t$key => $info{$key}";
      }
    }
  }

  print "Constraints: ";
  my %uniq = $package->unique_constraints;
  map { print "\t$_ => ", join ", " => @{ $uniq{$_} } } keys %uniq;
}


1;
__END__