File Coverage

blib/lib/Arguments.pm

Criterion	Covered	Total	%
statement	42	115	36.5
branch	0	30	0.0
condition	0	3	0.0
subroutine	15	19	78.9
pod	0	3	0.0
total	57	170	33.5

#
# Arguments.pm -- Perl subroutine type-checking
#
# $Id: Arguments.pm,v 1.2 2001/10/07 21:38:35 binkley Exp $
#

package Arguments;

use v5.6;
use strict;
use warnings;

use constant RCSID =>
  '$Id: Arguments.pm,v 1.2 2001/10/07 21:38:35 binkley Exp $';

use Carp ( );
use Devel::Peek ( );

# 'our' won't work since we haven't been processed yet when
# MODIFY_CODE_ATTRIBUTES is called.  Weird.  --bko FIXME
use vars qw(@DELAYED_CHECKS %ARGUMENT_CHECKS);

# Evil sets in.  Arrange for ourselves to be in the importer's @ISA so
# that MODIFY_CODE_ATTRIBUTES works without the importer needing to
# declare us as a base package.
sub import {
  no strict qw(refs);

  my $caller = caller;
  push @{"$caller\::ISA"}, __PACKAGE__;
}

# Add them rather than redefine the hash so that other modules have a
# chance to install their own during BEGIN before we are compiled.
$ARGUMENT_CHECKS{REF} ||= sub { UNIVERSAL::isa ($_[0], $_[1]) };
$ARGUMENT_CHECKS{RX} ||= sub { defined $_[0] and $_[0] =~ $_[1] };

# Convience.
our $Arguments_Package = __PACKAGE__;

# For error messages
sub _quote_strings {
  my @s;

  for (@_) {
    push @s, (defined $_ ? do {
      my $s = $_;
      $s =~ s/\\/\\\\/g;
      $s =~ s/'/\\'/g;
      "'$s'";
    } : 'undef');
  }

  @s;
}

# Cribbed from dumpvar.pl.
sub find_sub_name ($) {
  my $code = shift;
  $code = \&$code;		# guarantee a hard reference

  my $gv = Devel::Peek::CvGV ($code) or return;

  *$gv{PACKAGE} . '::' . *$gv{NAME};
}

# We don't want to be bothered by "%s package attribute may clash with
# future reserved word: %s" for MODIFY_CODE_ATTRIBUTES.  HOW DO YOU
# MAKE THIS WORK??  --bko XXX
{
  no warnings qw(reserved);

  sub MODIFY_CODE_ATTRIBUTES {
    my ($package, $coderef, @attributes) = @_;

    my @arguments = map {
      my $s = $_;
      $s =~ s/^$Arguments_Package\s*\(\s*//;
      $s =~ s/\s*\)$//;
      split /\s*,\s*/, $s;
    } grep /^$Arguments_Package\s*\(/, @attributes;

    if (0) {
      # Collect the true source of any problems.
      my @caller = qw(package filename line subroutine hasargs wantarray
		      evaltext is_require hints bitmask);
      my %caller;
      @caller{@caller} = do { package DB; caller (1) };

      push @DELAYED_CHECKS,
	[$package, $coderef, [@arguments], {%caller}];

    } else {
      my $longmess;

      {
	local $Carp::CarpLevel = 1;
	$longmess = Carp::longmess ('');
      }

      $longmess =~ s/\n.*//s;

      # The funky last argument is so that croak looks right
      push @DELAYED_CHECKS,
	[$package, $coderef, [@arguments], $longmess];
    }

    grep !/^$Arguments_Package\s*\(/, @attributes;
  }
}

sub synthesize_call_wrapper ($$$$@) {
  my ($package, $sub_name, $prototype, $longmess, @arguments) = @_;
  my $required = grep !/\?$/, @arguments;
  my $optional = @arguments;

  my $coderef;
  { no strict qw(refs); $coderef = *{$sub_name}{CODE} }

  my $s = "sub ($prototype) {
  Carp::croak \"Not enough arguments for $sub_name\"
    if \@_ < $required;
  Carp::croak \"Too many arguments for $sub_name\"
    if \@_ > $optional;
";

  my $i = 0;

  for my $a (@arguments) {
    my $j = $i + 1;

    $s .= "  Carp::croak \"Type of arg $j to $sub_name must be $a (not \"
       . defined \$_[$i] ? \$_[$i] : 'undef' . ')'
";

    # How to handle these?  --bko FIXME
    my $opt = $a =~ s/\?$//;

    if (exists $ARGUMENT_CHECKS{$a}) {
      $s .= "        unless \$ARGUMENT_CHECKS{'$a'}->(\$_[$i]);
";

    } elsif ($a =~ /^\//) {
      eval "use strict; use warnings; qr$a";

      if ($@) {
	# Hide the eval
	my ($s) = $@ =~ /(.*) at .*$/;
	Carp::croak "$s$longmess.\n"; # test RX first
      }

      $s .= "        unless \$ARGUMENT_CHECKS{RX}->(\$_[$i], qr$a);
";

    } else {
      eval "use strict; use warnings; \${'$a'};";

      if ($@) {
	# Hide the eval
	my ($s) = $@ =~ /(.*) at .*$/;
	Carp::croak "$s$longmess.\n"; # test RX first
      }


      $s .= "        unless \$ARGUMENT_CHECKS{REF}->(\$_[$i], '$a');
";
    }

    $i = $j;
  }

  $s .= "
  goto &\$coderef;
};
";

  # The 'misc' warning is weird -- eval keep seeing "unrecognized
  # escape \d" while dealing with /^\d+$/ (an unsigned integer), which
  # doesn't seem right.  --bko FIXME
  { no strict qw(refs); no warnings qw(misc redefine);
    *{$sub_name} = eval $s }

  croak $@ if $@;
}

sub process_delayed_checks ( ) {
  for (@DELAYED_CHECKS) {
    my ($package, $coderef, $arguments, $longmess) = @$_;
    my @arguments = @$arguments;

    my $prototype = prototype $coderef;

    # Normal, variadic sub.
    return if not defined $prototype and not @arguments;

    my $sub_name = find_sub_name $coderef;
    my (@prototypes, $ref, $opt);

    for my $token (split //, $prototype) {
      if ($ref) {
	undef $ref;
	push @prototypes, $opt ? "\\$token?" : "\\$token";

      } elsif ($token eq ';') {
	$opt = 1;

      } elsif ($token eq "\\") {
	$ref = 1;

      } else {
	push @prototypes, $opt ? "$token?" : $token;
      }
    }

    # Check that they match.  Use the "\n" trick from Carp::Heavy.
    Carp::croak "Not enough prototypes for $sub_name$longmess.\n"
      if @arguments < @prototypes;
    Carp::croak "Too many prototypes for $sub_name$longmess.\n"
      if @arguments > @prototypes;

    synthesize_call_wrapper
      ($package, $sub_name, $prototype, $longmess, @arguments);
  }
}

# Work around that subs don't have prototypes defined yet at the time
# that attributes are processed.  I'd consider this a bug. --bko FIXME
{
  # We need to be in the main package do delay our processing until
  # all the other packages have had a chance to declare and/or define
  # their prototypes.  Otherwise, we get called too soon, and
  # encounter the 'no prototypes' bug.  --bko FIXME
  package main;

  CHECK {
    # This will try to move the problem so that it shows up in the sub
    # declaration rather that in this processing.
    local $Carp::CarpLevel = 3;
    Arguments::process_delayed_checks ( );
  }
}

1;

__END__