Importing Sub-Prototype-Util-0.04.tar.gz

diff --git a/Changes b/Changes
index ecf455ada0d69d8931be935dc4e550753424ed06..cd90ae301296fe17d6f5ad7c6cd01bcc19359092 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,11 @@
 Revision history for Sub-Prototype-Util
 
 Revision history for Sub-Prototype-Util
 

+0.04    2008-04-09 13:25 UTC
+        + Fix : recall() should pass by reference as much as possible, or we
+                won't be able to apply it to functions that modify their
+                arguments (e.g. open()).
+        + Fix : our really doesn't exist in 5.005.
+

 0.03    2008-04-06 22:20 UTC
         + Fix : our doesn't exist in 5.005 (sigh).
         + Fix : '_' prototype should use the current argument when it's
 0.03    2008-04-06 22:20 UTC
         + Fix : our doesn't exist in 5.005 (sigh).
         + Fix : '_' prototype should use the current argument when it's

diff --git a/META.yml b/META.yml
index 4014ea5a4c25a6c7756684da6f7e30ea3d37881d..7300b253a21be80fb2d1709756ee0efcb552adde 100644 (file)
--- a/META.yml
+++ b/META.yml
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                Sub-Prototype-Util
 --- #YAML:1.0
 name:                Sub-Prototype-Util

-version:             0.03
+version:             0.04

 abstract:            Prototype-related utility routines.
 license:             perl
 author:              
 abstract:            Prototype-related utility routines.
 license:             perl
 author:              

diff --git a/README b/README
index 2865eb14b37e835001f2396a8a3ecd4f33894bd3..2971b31c9f02803257832191dfff9722047720c0 100644 (file)
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ NAME
     Sub::Prototype::Util - Prototype-related utility routines.
 
 VERSION
     Sub::Prototype::Util - Prototype-related utility routines.
 
 VERSION

-    Version 0.03
+    Version 0.04

 
 SYNOPSIS
         use Sub::Prototype::Util qw/flatten recall/;
 
 SYNOPSIS
         use Sub::Prototype::Util qw/flatten recall/;

diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index 2e2a5045a6f9fafadfb35492e42bfba9f7c0984c..5c0c04ee99770eeb18bfc44cb5b9e1ea33342f6f 100644 (file)
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -12,13 +12,13 @@ Sub::Prototype::Util - Prototype-related utility routines.
 
 =head1 VERSION
 
 
 =head1 VERSION
 

-Version 0.03
+Version 0.04

 
 =cut
 
 use vars qw/$VERSION/;
 
 
 =cut
 
 use vars qw/$VERSION/;
 

-$VERSION = '0.03';
+$VERSION = '0.04';

 
 =head1 SYNOPSIS
 
 
 =head1 SYNOPSIS
 


@@ -101,33 +101,35 @@ will call C<push @$a, 1, 2, 3> and so fill the arrayref C<$a> with C<1, 2, 3>. T
 =cut
 
 sub recall {
 =cut
 
 sub recall {

- my ($name, @a) = @_;
+ my $name = shift;

  croak 'Wrong subroutine name' unless $name;
  $name =~ s/^\s+//;
  $name =~ s/[\s\$\@\%\*\&;].*//;
  my $proto = prototype $name;
  my @args;
  croak 'Wrong subroutine name' unless $name;
  $name =~ s/^\s+//;
  $name =~ s/[\s\$\@\%\*\&;].*//;
  my $proto = prototype $name;
  my @args;

+ my @cr;

  if (defined $proto) {
   my $i = 0;
   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
    my $p = $2;
    if ($1) {
  if (defined $proto) {
   my $i = 0;
   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
    my $p = $2;
    if ($1) {

-    my $r = _check_ref $a[$i], $p;
-    push @args, join '', $sigils{$r}, '{$a[', $i, ']}';
+    my $r = _check_ref $_[$i], $p;
+    push @args, join '', $sigils{$r}, '{$_[', $i, ']}';

    } elsif ($p =~ /[\@\%]/) {
    } elsif ($p =~ /[\@\%]/) {

-    push @args, join '', '@a[', $i, '..', (@a - 1), ']';
+    push @args, join '', '@_[', $i, '..', (@_ - 1), ']';

     last;
    } elsif ($p =~ /\&/) {
     last;
    } elsif ($p =~ /\&/) {

-    push @args, 'sub{&{$a[' . $i . ']}}';
-   } elsif ($p eq '_' && $i >= @a) {
+    push @cr, $_[$i];
+    push @args, 'sub{&{$cr[' . $#cr . ']}}';
+   } elsif ($p eq '_' && $i >= @_) {

     push @args, '$_';
    } else {
     push @args, '$_';
    } else {

-    push @args, '$a[' . $i . ']';
+    push @args, '$_[' . $i . ']';

    }
    ++$i; 
   }
  } else {
    }
    ++$i; 
   }
  } else {

-  @args = map '$a[' . $_ . ']', 0 .. @a - 1;
+  @args = map '$_[' . $_ . ']', 0 .. @_ - 1;

  }
  my @ret = eval $name . '(' . join(',', @args) . ');';
  croak $@ if $@;
  }
  my @ret = eval $name . '(' . join(',', @args) . ');';
  croak $@ if $@;


@@ -142,11 +144,13 @@ The functions L</flatten> and L</recall> are only exported on request, either by
 
 use base qw/Exporter/;
 
 
 use base qw/Exporter/;
 

-our @EXPORT         = ();
-our %EXPORT_TAGS    = (
+use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
+
+@EXPORT             = ();
+%EXPORT_TAGS        = (

  'funcs' =>  [ qw/flatten recall/ ]
 );
  'funcs' =>  [ qw/flatten recall/ ]
 );

-our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
+@EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;

 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 
 =head1 DEPENDENCIES
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 
 =head1 DEPENDENCIES

diff --git a/t/11-recall.t b/t/11-recall.t
index 492594615e7b137b5810d022dc5c562f5eacea2c..0c48dbb5cce5ef92a6f2d5b6a213fee82e08c9ea 100644 (file)
--- a/t/11-recall.t
+++ b/t/11-recall.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
 use strict;
 use warnings;
 

-use Test::More tests => 3 + 12 + (($^V ge v5.10.0) ? 4 : 0);
+use Test::More tests => 3 + 14 + (($^V ge v5.10.0) ? 4 : 0);

 
 use Scalar::Util qw/set_prototype/;
 use Sub::Prototype::Util qw/recall/;
 
 use Scalar::Util qw/set_prototype/;
 use Sub::Prototype::Util qw/recall/;


@@ -16,11 +16,14 @@ eval { recall 'hlagh' };
 like($@, qr/^Undefined\s+subroutine/, 'recall <unknown> croaks');
 
 sub noproto { $_[1], $_[0] }
 like($@, qr/^Undefined\s+subroutine/, 'recall <unknown> croaks');
 
 sub noproto { $_[1], $_[0] }

-sub mytrunc ($;$) { $_[1], $_[0] };
-sub mygrep1 (&@) { grep { $_[0]->() } @_[1 .. $#_] };
-sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] };
+sub mytrunc ($;$) { $_[1], $_[0] }
+sub mygrep1 (&@) { grep { $_[0]->() } @_[1 .. $#_] }
+sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] }
+sub modify ($) { my $old = $_[0]; $_[0] = 5; $old }
+

 my $t = [ 1, 2, 3, 4 ];
 my $g = [ sub { $_ > 2 }, 1 .. 5 ];
 my $t = [ 1, 2, 3, 4 ];
 my $g = [ sub { $_ > 2 }, 1 .. 5 ];

+

 my @tests = (
  [ 'main::noproto', 'no prototype', $t, $t, [ 2, 1 ] ],
  [ 'CORE::push', 'push', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3, 5 ], 3, 5 ], [ 4 ] ],
 my @tests = (
  [ 'main::noproto', 'no prototype', $t, $t, [ 2, 1 ] ],
  [ 'CORE::push', 'push', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3, 5 ], 3, 5 ], [ 4 ] ],


@@ -28,7 +31,9 @@ my @tests = (
  [ 'main::mytrunc', 'truncate 2', $t, $t, [ 2, 1 ] ],
  [ 'main::mygrep1', 'grep1', $g, $g, [ 3 .. 5 ] ],
  [ 'main::mygrep2', 'grep2', $g, $g, [ 3 .. 5 ] ],
  [ 'main::mytrunc', 'truncate 2', $t, $t, [ 2, 1 ] ],
  [ 'main::mygrep1', 'grep1', $g, $g, [ 3 .. 5 ] ],
  [ 'main::mygrep2', 'grep2', $g, $g, [ 3 .. 5 ] ],

+ [ 'main::modify', 'modify arguments', [ 1 ], [ 5 ], [ 1 ] ],

 );
 );

+

 sub myit { push @{$_[0]->[2]}, 3; return 4 };
 if ($^V ge v5.10.0) {
  set_prototype \&myit, '_';
 sub myit { push @{$_[0]->[2]}, 3; return 4 };
 if ($^V ge v5.10.0) {
  set_prototype \&myit, '_';