view release on metacpan or  search on metacpan

Arguments.pm  view on Meta::CPAN

  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
      }