File Coverage

blib/lib/Attribute/Signature.pm

Criterion	Covered	Total	%
statement	123	134	91.7
branch	53	76	69.7
condition	13	21	61.9
subroutine	19	19	100.0
pod	5	7	71.4
total	213	257	82.8

package Attribute::Signature;

use 5.006;
use strict;
#use warnings::register;

use Carp;
use Scalar::Util qw ( blessed );

#use Data::Dumper;
use Attribute::Handlers;
use attributes ();
#local $^W=0;

our $VERSION    = '1.11';
my  $SIGNATURES = {};

sub UNIVERSAL::with : ATTR(CODE,INIT) {
  my ($package, $symbol, $referent, $attr, $data) = @_;

  my $large   = *{$symbol}{NAME};
  my $subname = substr($large, rindex($large, ':') + 1);

  no warnings qw( redefine );

  ## make sure we have an array ref, so its easier
  if (!ref($data)) {
    $data = [ $data ];
  }

  ## save this for later use
  $SIGNATURES->{$package}->{with}->{$subname} = $data;

  my $attributes = { map { ($_, 1) } attributes::get( $referent ) };

  if ($attributes->{method}) {
    print "Signature on sub $subname is for a method\n" if $::AS_DEBUG;
    unshift @$data, $package;  ## put a placeholder in the front
  }

  *{$symbol} = sub {
    my $i = 0;
    my $count = scalar(@_);

    if ($attributes->{method}) {
      $i = 1;
    }

    if ($count != scalar(@$data)) {
      if ($attributes->{method}) {
	croak("invalid number of arguments passed to method $subname");
      } else {
	croak("invalid number of arguments passed to subroutine $subname ($count passed, ".scalar(@$data)." required");
      }
    }

    my $m = 0;
    print "Comparisons\n" if $::AS_DEBUG;
    print "\tSignature\tValue\n" if $::AS_DEBUG;
    my @failed;
    while($i <= $count) {
      print "\t$data->[$i]\t\t$_[$i]\n" if $::AS_DEBUG;
      last unless $data->[$i];
      my $ok=0;
      if (lc($data->[$i]) eq $data->[$i]) {
	## here we are checking for little types
	my $type = $data->[$i];
	if (Attribute::Signature->can( $type )) {
	  if (Attribute::Signature->$type( $_[$i] )) {
	    $ok++;
	  }
	}
      } elsif ((blessed($_[$i])) && $_[$i]->isa( $data->[$i]) ) {
      # || string($_[$i])
	$ok++;
      } elsif (!blessed($_[$i]) && ref($_[$i]) eq $data->[$i]) {
	$ok++;
      }
      if ($ok) {
        $m++ ;
      } else {
        push @failed,$i;
      }
      $i++;
    }

    if ($attributes->{method}) { $m++; }

    print "Out of band:\n\tCount\tMatched\n\t$count\t$m\n" if defined $::AS_DEBUG && $::AS_DEBUG;

    if ($m != $count) {
      croak("call to $subname does not match signature (failed args:".join(',',@failed).")");
    } else {
      #$referent->( @_ );
      goto &$referent;
    }
  };
}

sub UNIVERSAL::returns : ATTR(CODE,INIT) {
  my ($package, $symbol, $referent, $attr, $data) = @_;

  my $large   = *{$symbol}{NAME};
  my $subname = substr($large, rindex($large, ':') + 1);

  no warnings qw( redefine );

  ## make sure we have an array ref, so its easier
  if (!ref($data)) {
    $data = [ $data ];
  }

  ## save this for later use
  $SIGNATURES->{$package}->{returns}->{$subname} = $data;

  my $attributes = { map { ($_, 1) } attributes::get( $referent ) };

  if ($attributes->{method}) {
    print "Signature on sub $subname is for a method\n" if $::AS_DEBUG;
    unshift @$data, $package;  ## put a placeholder in the front
  }

  *{$symbol} = sub {

    my @return = $referent->( @_ );

    my $i = 0;
    my $count = scalar(@return);

    if ($count != scalar(@$data)) {
      if ($attributes->{method}) {
	croak("invalid number of arguments returned from method $subname");
      } else {
	croak("invalid number of arguments returned from subroutine $subname");
      }
    }

    my $m = 0;
    print "ReturnComparisons\n" if $::AS_DEBUG;
    print "\tSignature\tValue\n" if $::AS_DEBUG;
    while($i <= $count) {
      print "\t$data->[$i]\t\t$return[$i]\n" if $::AS_DEBUG;
      last unless $data->[$i];
      if (lc($data->[$i]) eq $data->[$i]) {
	## here we are checking for little types
	my $type = $data->[$i];
	if (Attribute::Signature->can( $type )) {
	  if (Attribute::Signature->$type( $return[$i] )) {
	    $m++;
	  }
	}
      } elsif ($data->[$i] eq 'REF' && ref($return[$i])) {
	$m++;
#      } elsif ((blessed($return[$i]) || string($return[$i])) && $return[$i]->isa( $data->[$i]) ) {
      } elsif (blessed($return[$i]) && $return[$i]->isa( $data->[$i]) ) {
	$m++;
      } elsif (!blessed($return[$i]) && ref($return[$i]) eq $data->[$i]) {
	$m++;
      } else {
	# no match
      }
      $i++;
    }

    if ($attributes->{method}) { $m++; }

    print "ReturnOut of band:\n\tCount\tMatched\n\t$count\t$m\n" if $::AS_DEBUG;

    if ($m != $count) {
      croak("Arguments returned from $subname do not match signature $m != $count");
    } else {
      $referent->( @_ );
    }
  };
}

sub getSignature  {
  my $class = shift;
  my $fqsn  = shift;

  ## this is my sub && package
  my $subname = substr($fqsn, rindex($fqsn, ':') + 1);
  my $package = substr($fqsn, 0, rindex($fqsn, '::'));

  if (wantarray) {
    return($SIGNATURES->{$package}->{with}->{$subname}, $SIGNATURES->{$package}->{returns}->{$subname});
  } else {
    return $SIGNATURES->{$package}->{with}->{$subname};
  }
}

sub string {
  my $class = shift;
  return not ref $_[0];
}

sub number {
  my $class = shift;
  return $class->float($_[0]) || $class->integer($_[0]);
}

sub float {
  my $class = shift;
  return $_[0] =~ /^\d*\.\d*$/;
}

sub integer {
  my $class = shift;
  return $_[0] =~ /^\d+$/;
}

1;

__END__