File Coverage

blib/lib/Test/SQL/Translator.pm

Criterion	Covered	Total	%
statement	181	191	94.7
branch	39	60	65.0
condition	4	8	50.0
subroutine	19	19	100.0
pod	7	11	63.6
total	250	289	86.5

package Test::SQL::Translator;

=pod

=head1 NAME

Test::SQL::Translator - Test::More test functions for the Schema objects.

=cut

use strict;
use warnings;
use Test::More;
use SQL::Translator::Schema::Constants;

use base qw(Exporter);
our @EXPORT_OK;
our $VERSION = '1.66';
our @EXPORT  = qw(
  schema_ok
  table_ok
  field_ok
  constraint_ok
  index_ok
  view_ok
  trigger_ok
  procedure_ok
  maybe_plan
);

# $ATTRIBUTES{  } = {  => , ... }
my %ATTRIBUTES = (
  field => {
    name              => undef,
    data_type         => '',
    default_value     => undef,
    size              => '0',
    is_primary_key    => 0,
    is_unique         => 0,
    is_nullable       => 1,
    is_foreign_key    => 0,
    is_auto_increment => 0,
    comments          => '',
    extra             => {},

    # foreign_key_reference,
    is_valid => 1,

    # order
  },
  constraint => {
    name             => '',
    type             => '',
    deferrable       => 1,
    expression       => '',
    is_valid         => 1,
    fields           => [],
    match_type       => '',
    options          => [],
    on_delete        => '',
    on_update        => '',
    reference_fields => [],
    reference_table  => '',
    extra            => {},
  },
  index => {
    fields   => [],
    is_valid => 1,
    name     => "",
    options  => [],
    type     => NORMAL,
    extra    => {},
  },
  view => {
    name     => "",
    sql      => "",
    fields   => [],
    is_valid => 1,
    extra    => {},
  },
  trigger => {
    name                => '',
    perform_action_when => undef,
    database_events     => undef,
    on_table            => undef,
    action              => undef,
    is_valid            => 1,
    extra               => {},
  },
  procedure => {
    name       => '',
    sql        => '',
    parameters => [],
    owner      => '',
    comments   => '',
    extra      => {},
  },
  table => {
    comments => undef,
    name     => '',

    #primary_key => undef, # pkey constraint
    options => [],

    #order      => 0,
    fields      => undef,
    constraints => undef,
    indices     => undef,
    is_valid    => 1,
    extra       => {},
  },
  schema => {
    name       => '',
    database   => '',
    procedures => undef,    # [] when set
    tables     => undef,    # [] when set
    triggers   => undef,    # [] when set
    views      => undef,    # [] when set
    is_valid   => 1,
    extra      => {},
  }
);

# Given a test hash and schema object name set any attribute keys not present in
# the test hash to their default value for that schema object type.
# e.g. default_attribs( $test, "field" );
sub default_attribs {
  my ($hashref, $object_type) = @_;

  if (!exists $ATTRIBUTES{$object_type}) {
    die "Can't add default attribs for unknown Schema " . "object type '$object_type'.";
  }

  for my $attr (
    grep { !exists $hashref->{$_} }
    keys %{ $ATTRIBUTES{$object_type} }
  ) {
    $hashref->{$attr} = $ATTRIBUTES{$object_type}{$attr};
  }

  return $hashref;
}

# Format test name so it will prepend the test names used below.
sub t_name {
  my $name = shift;
  $name ||= "";
  $name = "$name - " if $name;
  return $name;
}

sub field_ok {
  my ($f1, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "field");

  unless ($f1) {
    fail " Field '$test->{name}' doesn't exist!";

    # TODO Do a skip on the following tests. Currently the test counts wont
    # match at the end. So at least it fails.
    return;
  }

  my $full_name = $f1->table->name . "." . $test->{name};

  is($f1->name, $test->{name}, "${t_name}Field '$full_name'");

  is($f1->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  is($f1->data_type, $test->{data_type}, "$t_name    type is '$test->{data_type}'");

  is($f1->size, $test->{size}, "$t_name    size is '$test->{size}'");

  is(
    $f1->default_value,
    $test->{default_value},
    "$t_name    default value is "
        . (
          defined($test->{default_value})
          ? "'$test->{default_value}'"
          : "UNDEF"
        )
  );

  is($f1->is_nullable, $test->{is_nullable}, "$t_name    " . ($test->{is_nullable} ? 'can' : 'cannot') . ' be null');

  is($f1->is_unique, $test->{is_unique}, "$t_name    " . ($test->{is_unique} ? 'can' : 'cannot') . ' be unique');

  is(
    $f1->is_primary_key,
    $test->{is_primary_key},
    "$t_name    is " . ($test->{is_primary_key} ? '' : 'not ') . 'a primary_key'
  );

  is(
    $f1->is_foreign_key,
    $test->{is_foreign_key},
    "$t_name    is " . ($test->{is_foreign_key} ? '' : 'not') . ' a foreign_key'
  );

  is(
    $f1->is_auto_increment,
    $test->{is_auto_increment},
    "$t_name    is " . ($test->{is_auto_increment} ? '' : 'not ') . 'an auto_increment'
  );

  is($f1->comments, $test->{comments}, "$t_name    comments");

  is_deeply({ $f1->extra }, $test->{extra}, "$t_name    extra");
}

sub constraint_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "constraint");

  is($obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'");

  is($obj->type, $test->{type}, "$t_name    type is '$test->{type}'");

  is($obj->deferrable, $test->{deferrable}, "$t_name    " . ($test->{deferrable} ? 'can' : 'cannot') . ' be deferred');

  is($obj->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  is($obj->table->name, $test->{table}, "$t_name    table is '$test->{table}'");

  is($obj->expression, $test->{expression}, "$t_name    expression is '$test->{expression}'");

  is_deeply([ $obj->fields ], $test->{fields}, "$t_name    fields are '" . join(",", @{ $test->{fields} }) . "'");

  is($obj->reference_table, $test->{reference_table}, "$t_name    reference_table is '$test->{reference_table}'");

  is_deeply(
    [ $obj->reference_fields ],
    $test->{reference_fields},
    "$t_name    reference_fields are '" . join(",", @{ $test->{reference_fields} }) . "'"
  );

  is($obj->match_type, $test->{match_type}, "$t_name    match_type is '$test->{match_type}'");

  is($obj->on_delete, $test->{on_delete}, "$t_name    on_delete is '$test->{on_delete}'");

  is($obj->on_update, $test->{on_update}, "$t_name    on_update is '$test->{on_update}'");

  is_deeply([ $obj->options ], $test->{options}, "$t_name    options are '" . join(",", @{ $test->{options} }) . "'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");
}

sub index_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "index");

  is($obj->name, $test->{name}, "${t_name}Index '$test->{name}'");

  is($obj->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  is($obj->type, $test->{type}, "$t_name    type is '$test->{type}'");

  is_deeply([ $obj->fields ], $test->{fields}, "$t_name    fields are '" . join(",", @{ $test->{fields} }) . "'");

  is_deeply([ $obj->options ], $test->{options}, "$t_name    options are '" . join(",", @{ $test->{options} }) . "'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");
}

sub trigger_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "index");

  is($obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'");

  is($obj->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  is(
    $obj->perform_action_when,
    $test->{perform_action_when},
    "$t_name    perform_action_when is '$test->{perform_action_when}'"
  );

  is(
    join(',', $obj->database_events),
    $test->{database_events},
    sprintf("%s    database_events is '%s'", $t_name, $test->{'database_events'},)
  );

  is($obj->on_table, $test->{on_table}, "$t_name    on_table is '$test->{on_table}'");

  is($obj->scope, $test->{scope}, "$t_name    scope is '$test->{scope}'")
      if exists $test->{scope};

  is($obj->action, $test->{action}, "$t_name    action is '$test->{action}'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");
}

sub view_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "index");

  #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );

  is($obj->name, $test->{name}, "${t_name}View '$test->{name}'");

  is($obj->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  is($obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'");

  is_deeply([ $obj->fields ], $test->{fields}, "$t_name    fields are '" . join(",", @{ $test->{fields} }) . "'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");
}

sub procedure_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "index");

  #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );

  is($obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'");

  is($obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'");

  is_deeply([ $obj->parameters ],
    $test->{parameters}, "$t_name    parameters are '" . join(",", @{ $test->{parameters} }) . "'");

  is($obj->comments, $test->{comments}, "$t_name    comments is '$test->{comments}'");

  is($obj->owner, $test->{owner}, "$t_name    owner is '$test->{owner}'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");
}

sub table_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "table");
  my %arg = %$test;

  my $tbl_name = $arg{name} || die "Need a table name to test.";
  is($obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'");

  is_deeply([ $obj->options ], $test->{options}, "$t_name    options are '" . join(",", @{ $test->{options} }) . "'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");

  # Fields
  if ($arg{fields}) {
    my @fldnames = map { $_->{name} } @{ $arg{fields} };
    is_deeply([ map { $_->name } $obj->get_fields ],
      [@fldnames], "${t_name}    field names are " . join(", ", @fldnames));
    foreach (@{ $arg{fields} }) {
      my $f_name = $_->{name} || die "Need a field name to test.";
      next unless my $fld = $obj->get_field($f_name);
      field_ok($fld, $_, $name);
    }
  } else {
    is(scalar($obj->get_fields), undef, "${t_name}    has no fields.");
  }

  # Constraints and Indices
  _test_kids(
    $obj, $test, $name,
    {
      constraint => 'constraints',
      index      => 'indices',
    }
  );
}

sub _test_kids {
  my ($obj, $test, $name, $kids) = @_;
  my $t_name   = t_name($name);
  my $obj_name = ref $obj;
  ($obj_name) = $obj_name =~ m/^.*::(.*)$/;

  while (my ($object_type, $plural) = each %$kids) {
    next unless defined $test->{$plural};

    if (my @tests = @{ $test->{$plural} }) {
      my $meth    = "get_$plural";
      my @objects = $obj->$meth;
      is(scalar(@objects), scalar(@tests), "${t_name}$obj_name has " . scalar(@tests) . " $plural");

      for my $object (@objects) {
        my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };

        my $meth = "${object_type}_ok";
        {
          no strict 'refs';
          $meth->($object, $ans, $name);
        }
      }
    }
  }
}

sub schema_ok {
  my ($obj, $test, $name) = @_;
  my $t_name = t_name($name);
  default_attribs($test, "schema");

  is($obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'");

  is($obj->database, $test->{database}, "$t_name    database is '$test->{database}'");

  is_deeply({ $obj->extra }, $test->{extra}, "$t_name    extra");

  is($obj->is_valid, $test->{is_valid}, "$t_name    is " . ($test->{is_valid} ? '' : 'not ') . 'valid');

  # Tables
  if ($test->{tables}) {
    is_deeply(
      [ map { $_->name } $obj->get_tables ],
      [ map { $_->{name} } @{ $test->{tables} } ],
      "${t_name}    table names match"
    );
    foreach (@{ $test->{tables} }) {
      my $t_name = $_->{name} || die "Need a table name to test.";
      table_ok($obj->get_table($t_name), $_, $name);
    }
  } else {
    is(scalar($obj->get_tables), undef, "${t_name}    has no tables.");
  }

  # Procedures, Triggers, Views
  _test_kids(
    $obj, $test, $name,
    {
      procedure => 'procedures',
      trigger   => 'triggers',
      view      => 'views',
    }
  );
}

# maybe_plan($ntests, @modules)
#
# Calls plan $ntests if @modules can all be loaded; otherwise,
# calls skip_all with an explanation of why the tests were skipped.
sub maybe_plan {
  my ($ntests, @modules) = @_;
  my @errors;

  for my $module (@modules) {
    eval "use $module;";
    next if !$@;

    if ($@ =~ /Can't locate (\S+)/) {
      my $mod = $1;
      $mod =~ s/\.pm$//;
      $mod =~ s#/#::#g;
      push @errors, $mod;
    } elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
      push @errors, $1;
    } elsif ($@ =~ /Can't load .+? for module .+?DynaLoader\.pm/i) {
      push @errors, $module;
    } else {
      (my $err = $@) =~ s/\n+/\\n/g;    # Can't have newlines in the skip message
      push @errors, "$module: $err";
    }
  }

  if (@errors) {
    my $msg = sprintf "Missing dependenc%s: %s", @errors == 1 ? 'y' : 'ies', join ", ", @errors;
    plan skip_all => $msg;
  }
  return unless defined $ntests;

  if ($ntests ne 'no_plan') {
    plan tests => $ntests;
  } else {
    plan 'no_plan';
  }
}

1;    # compile please ===========================================================
__END__