Fix some croak backtraces

[perl/modules/Sub-Prototype-Util.git] / lib / Sub / Prototype / Util.pm

diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index a92647f6a4d224985ff72ac11dea3fd75ed980ca..20525ece0971b354170d655b1ce89b344100467c 100644 (file)
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -57,6 +57,12 @@ sub _check_ref {
  return $r;
 }
 
+sub _clean_msg {
+ my ($msg) = @_;
+ $msg =~ s/(?:\s+called)?\s+at\s+.*$//s;
+ return $msg;
+}
+
 =head2 C<flatten $proto, @args>
 
 Flattens the array C<@args> according to the prototype C<$proto>. When C<@args> is what C<@_> is after calling a subroutine with prototype C<$proto>, C<flatten> returns the list of what C<@_> would have been if there were no prototype.
@@ -139,9 +145,8 @@ For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by us
 
 sub _wrap {
  my ($name, $proto, $i, $args, $cr, $opts) = @_;
- if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) {
+ while ($proto =~ s/(\\?)(\[[^\]]+\]|[^\];])//) {
   my ($ref, $p) = ($1, $2);
-  $proto = $3;
   $p = $1 if $p =~ /^\[([^\]]+)\]/;
   my $cur = '$_[' . $i . ']';
   if ($ref) {
@@ -176,11 +181,10 @@ sub _wrap {
   } else {
    $args .= $cur . ', ';
   }
-  return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
- } else {
-  $args =~ s/,\s*$//;
-  return $name . '(' . $args . ')';
+  ++$i;
  }
+ $args =~ s/,\s*$//;
+ return $name . '(' . $args . ')';
 }
 
 sub _check_name {
@@ -225,7 +229,7 @@ sub wrap {
  $call = 'sub ' . $call if $opts{sub};
  if ($opts{compile}) {
   $call = eval $call;
-  croak $@ if $@;
+  croak _clean_msg $@ if $@;
  }
  return $call;
 }
@@ -244,7 +248,7 @@ If you plan to recall several times, consider using L</wrap> instead.
 
 sub recall {
  my $wrap = eval { wrap shift };
- croak $@ if $@;
+ croak _clean_msg $@ if $@;
  return $wrap->(@_);
 }