File Coverage

blib/lib/Sub/Assert.pm

Criterion	Covered	Total	%
statement	132	151	87.4
branch	66	106	62.2
condition	3	9	33.3
subroutine	14	14	100.0
pod	1	1	100.0
total	216	281	76.8

package Sub::Assert;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw(
  assert
);
our $VERSION = '1.23';

use Carp qw/croak carp/;

sub assert {
  my %params = @_;
  my $sub    = $params{sub};
  defined $sub or croak("assert missing the subroutine to work with");

  my $package;
  my $subref;
  if (ref $sub eq 'CODE') {
    $subref = $sub;
  }
  elsif (ref $sub eq '') {
    ($package, undef, undef) = caller();
    defined $package
      or croak("assert could not determine caller package");
    no strict 'refs';
    $subref = *{"${package}::$sub"}{CODE};
    use strict 'refs';
    defined $subref and ref($subref) eq 'CODE'
      or croak("assert finds that there is no '$sub' subroutine in package '$package'");
  }
  else {
    croak("Subroutine argument to assert is invalid");
  }

  $params{action} = 'croak' unless defined $params{action};
  my $action = $package . '::' . $params{action};

  my $precond = _normalize_conditions($params{pre}, 'precondition');

  my $postcond = _normalize_conditions($params{post}, 'postcondition');

  my $context;
  if (exists $params{context}) {
    unless (defined $params{context} and
      $params{context} eq 'list' ||
      $params{context} eq 'scalar' ||
      $params{context} eq 'void' ||
      $params{context} eq 'novoid' ||
      $params{context} eq 'any'
    ) {
      croak("Invalid context specified for assertion");
    }
    $context = $params{context};
  }
  else {
    $context = 'any';
  }

  my $new_sub_text = "sub {\nmy \@PARAM = \@_;\n";

  if ($context eq 'list') {
    $new_sub_text .= "unless (wantarray()) {\n" .
         "my \$context = (defined wantarray() ?\n" .
          "      'scalar' : 'void');\n" .
         "$action(\"" .
         (ref($sub) eq 'CODE' ?
           'C' :
           "${package}::$sub c"
         ) .
         'alled in $context context.")' .
         "}\n";
  }
  elsif ($context eq 'scalar') {
    $new_sub_text .= "unless (defined(wantarray()) and not " .
         "wantarray()) {\n" .
         "my \$context = (wantarray() ?\n" .
          "      'list' : 'void');\n" .
         "$action(\"" .
         (ref($sub) eq 'CODE' ?
           'C' :
           "${package}::$sub c"
         ) .
         'alled in $context context.")' .
         "}\n";
  }
  elsif ($context eq 'novoid') {
    $new_sub_text .= "unless (defined wantarray()) {\n" .
         "$action(\"" .
         (ref($sub) eq 'CODE' ?
           'C' :
           "${package}::$sub c"
         ) .
         'alled in void context.")' .
         "}\n";
  }
  elsif ($context eq 'void') {
    $new_sub_text .= "unless (not defined wantarray()) {\n" .
         "my \$context = (wantarray() ?\n" .
          "      'list' : 'scalar');\n" .
         "$action(\"" .
         (ref($sub) eq 'CODE' ?
           'C' :
           "${package}::$sub c"
         ) .
         'alled in $context context.")' .
         "}\n";
  }

  foreach my $pre_name (keys %$precond) {
    if ($pre_name eq '_') {
      my $pre_array = $precond->{'_'};
      foreach my $pre_no (1..@$pre_array) {
        $new_sub_text .=
             "do{\n".$pre_array->[$pre_no-1]
             . "\n}\nor $action(\"Precondition "
             . "$pre_no "
             . (ref($sub) eq 'CODE' ? '' : "for ${package}::$sub ")
             . "failed.\");\n\n";
      }
    }
    else {
      $new_sub_text .=
           "do{\n".$precond->{$pre_name}
           . "\n}\nor $action(\"Precondition "
           . "'$pre_name' "
           . (ref($sub) eq 'CODE' ? '' : "for ${package}::$sub ")
           . "failed.\");\n\n";
    }
  }
  $new_sub_text .= <<'HERE';
my @RETURN;
my $RETURN;
my $VOID;
if (wantarray()) {
  @RETURN = $SUBROUTINEREF->(@PARAM);
  $RETURN = $RETURN[0] if @RETURN;
}
elsif (defined wantarray()) {
  $RETURN = $SUBROUTINEREF->(@PARAM);
  @RETURN = ($RETURN);
}
else {
  $VOID = 1;
  $SUBROUTINEREF->(@PARAM);
}
HERE

  foreach my $post_name (keys %$postcond) {
    if ($post_name eq '_') {
      my $post_array = $postcond->{'_'};
      foreach my $post_no (1..@$post_array) {
        $new_sub_text .=
             "do{\n".$post_array->[$post_no-1]
             . "\n}\nor $action(\"Postcondition "
             . "$post_no "
             . (ref($sub) eq 'CODE' ? '' : "for ${package}::$sub ")
             . "failed.\");\n\n";
      }
    }
    else {
      $new_sub_text .=
           "do{\n".$postcond->{$post_name}
           . "\n}\nor $action(\"Postcondition "
           . "'$post_name' "
           . (ref($sub) eq 'CODE' ? '' : "for ${package}::$sub ")
           . "failed.\");\n\n";
    }
  }

  $new_sub_text .= ($context eq 'list' ?
        "return \@RETURN;\n}\n" :
        "return \$RETURN;\n}\n"
       );
  my ($new_sub_ref, $error) =
    _generate_assertion_subroutine($subref, $new_sub_text);

  if ($error) {
    croak("Compilation of assertions failed: $error.\n$new_sub_text");
  }
  if (ref($sub) eq 'CODE') {
    return $new_sub_ref;
  }
  else {
    no strict;
    no warnings;
    *{"${package}::$sub"} = $new_sub_ref;
    use strict;
    use warnings;
  }
  return $new_sub_ref;
}

sub _generate_assertion_subroutine {
  local $@;
  my $SUBROUTINEREF = $_[0];
  return eval($_[1]), "$@";
}

sub _normalize_conditions {
  my $conditions = shift;
  my $type = shift;

  if (not defined $conditions) {
    # no conditions
    $conditions = {};
  }
  elsif (ref($conditions) eq '') {
    # a single, unnamed condition
    $conditions = {'_' =>[$conditions]};
  }
  elsif (ref($conditions) eq 'ARRAY') {
    # an array of unnamed conditions
    my $ary = $conditions;
    $conditions = {'_' => [@$ary]};
  }
  elsif (ref($conditions) eq 'HASH') {}
  else {
    croak("Invalid type of $type");
  }

  foreach my $name (keys %$conditions) {
    if ($name eq '_') {
      foreach my $cond (@{$conditions->{'_'}}) {
        croak("Invalid unnamed $type")
          if ref($cond) ne '';
      }
    }
    else {
      croak("Invalid $type '$name'")
        if ref($conditions->{$name}) ne '';
    }
  }

  return $conditions;
}

1;
__END__