r75049 - in /branches/upstream/liblist-moreutils-perl/current: Changes MANIFEST META.yml Makefile.PL MoreUtils.xs README lib/List/MoreUtils.pm sanexs.c t/lib/Test.pm xt/pmv.t

periapt-guest at users.alioth.debian.org periapt-guest at users.alioth.debian.org
Thu Jun 2 15:39:05 UTC 2011


Author: periapt-guest
Date: Thu Jun  2 15:38:56 2011
New Revision: 75049

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=75049
Log:
[svn-upgrade] new version liblist-moreutils-perl (0.32)

Added:
    branches/upstream/liblist-moreutils-perl/current/sanexs.c
Modified:
    branches/upstream/liblist-moreutils-perl/current/Changes
    branches/upstream/liblist-moreutils-perl/current/MANIFEST
    branches/upstream/liblist-moreutils-perl/current/META.yml
    branches/upstream/liblist-moreutils-perl/current/Makefile.PL
    branches/upstream/liblist-moreutils-perl/current/MoreUtils.xs
    branches/upstream/liblist-moreutils-perl/current/README
    branches/upstream/liblist-moreutils-perl/current/lib/List/MoreUtils.pm
    branches/upstream/liblist-moreutils-perl/current/t/lib/Test.pm
    branches/upstream/liblist-moreutils-perl/current/xt/pmv.t

Modified: branches/upstream/liblist-moreutils-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/Changes?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/Changes (original)
+++ branches/upstream/liblist-moreutils-perl/current/Changes Thu Jun  2 15:38:56 2011
@@ -1,4 +1,17 @@
-Revision history for Perl extension List-Any/List-MoreUtils
+Revision history for Perl extension List-MoreUtils
+
+0.32 Fri May 20 2011    
+	- Production release, no other changes
+
+0.31_02 Mon 21 Mar 2011
+	- More accurate detection of XS support (ADAMK)
+
+0.31_01 Mon 21 Mar 2011
+	- Updating copyright year (ADAMK)
+	- Teak documentation of all() and none() (WYANT)
+	- Memory leak fixed for apply() and XS version restored (ARC)
+	- Memory leak fixed for indexes() and XS version restored (ARC)
+	- Memory leak fixed for part() and XS version restored (ARC)
 
 0.30 Thu 16 Dec 2010
 	- Change the way we localise PERL_DL_NONLAZY to false to remove

Modified: branches/upstream/liblist-moreutils-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/MANIFEST?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/MANIFEST (original)
+++ branches/upstream/liblist-moreutils-perl/current/MANIFEST Thu Jun  2 15:38:56 2011
@@ -7,6 +7,7 @@
 MoreUtils.xs
 multicall.h
 README
+sanexs.c
 t/01_compile.t
 t/02_perl.t
 t/03_xs.t

Modified: branches/upstream/liblist-moreutils-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/META.yml?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/META.yml (original)
+++ branches/upstream/liblist-moreutils-perl/current/META.yml Thu Jun  2 15:38:56 2011
@@ -1,16 +1,18 @@
 --- #YAML:1.0
 name:               List-MoreUtils
-version:            0.30
+version:            0.32
 abstract:           Provide the stuff missing in List::Util
 author:
     - Tassilo von Parseval <tassilo.von.parseval at rwth-aachen.de>
 license:            perl
 distribution_type:  module
 configure_requires:
-    ExtUtils::MakeMaker:  0
+    ExtUtils::CBuilder:   0.27
+    ExtUtils::MakeMaker:  6.52
 build_requires:
-    ExtUtils::MakeMaker:  0
+    Test::More:  0.42
 requires:
+    perl:        5.00503
     Test::More:  0.82
 no_index:
     directory:

Modified: branches/upstream/liblist-moreutils-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/Makefile.PL?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/Makefile.PL (original)
+++ branches/upstream/liblist-moreutils-perl/current/Makefile.PL Thu Jun  2 15:38:56 2011
@@ -12,19 +12,29 @@
 	/^-xs/ and $make_xs = 1;
 }
 unless ( defined $make_xs ) {
-	$make_xs = can_cc();
+	$make_xs = can_xs();
 }
 
 WriteMakefile(
-	NAME         => 'List::MoreUtils',
-	ABSTRACT     => 'Provide the stuff missing in List::Util',
-	VERSION_FROM => 'lib/List/MoreUtils.pm',
-	AUTHOR       => 'Tassilo von Parseval <tassilo.von.parseval at rwth-aachen.de>',
-	LICENSE      => 'perl',
-	PREREQ_PM    => {
+	NAME               => 'List::MoreUtils',
+	ABSTRACT           => 'Provide the stuff missing in List::Util',
+	VERSION_FROM       => 'lib/List/MoreUtils.pm',
+	AUTHOR             => 'Tassilo von Parseval <tassilo.von.parseval at rwth-aachen.de>',
+	LICENSE            => 'perl',
+	MIN_PERL_VERSION   => '5.00503',
+	CONFIGURE_REQUIRES => {
+		'ExtUtils::MakeMaker' => '6.52',
+		'ExtUtils::CBuilder'  => '0.27',
+	},
+	BUILD_REQUIRES => {
+		'Test::More' => '0.42',
+	},
+	PREREQ_PM => {
 		'Test::More' => '0.82',
 	},
-	CONFIGURE    => sub {
+
+	# Special stuff
+	CONFIGURE => sub {
 		my $hash = $_[1];
 		unless ( $make_xs ) {
 			$hash->{XS} = { };
@@ -44,26 +54,78 @@
 ######################################################################
 # Support Functions
 
+# Modified from eumm-upgrade by Alexandr Ciornii.
 sub WriteMakefile {
-	my %params = @_;
-	my $eumm_version = $ExtUtils::MakeMaker::VERSION;
-	$eumm_version = eval $eumm_version;
+	my %params=@_;
+	my $eumm_version=$ExtUtils::MakeMaker::VERSION;
+	$eumm_version=eval $eumm_version;
 	die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
 	die "License not specified" unless exists $params{LICENSE};
-	if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
-		# EUMM 6.5502 has problems with BUILD_REQUIRES
-		$params{PREREQ_PM} = {
-			%{ $params{PREREQ_PM} || {} },
-			%{ $params{BUILD_REQUIRES}  }
-		};
+	if ( $params{BUILD_REQUIRES} and $eumm_version < 6.5503 ) {
+		#EUMM 6.5502 has problems with BUILD_REQUIRES
+		$params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
 		delete $params{BUILD_REQUIRES};
 	}
 	delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
 	delete $params{MIN_PERL_VERSION}   if $eumm_version < 6.48;
 	delete $params{META_MERGE}         if $eumm_version < 6.46;
+	delete $params{META_ADD}           if $eumm_version < 6.46;
 	delete $params{LICENSE}            if $eumm_version < 6.31;
 	delete $params{AUTHOR}             if $] < 5.005;
+	delete $params{ABSTRACT_FROM}      if $] < 5.005;
+	delete $params{BINARY_LOCATION}    if $] < 5.005;
 	ExtUtils::MakeMaker::WriteMakefile(%params);
+}
+
+# Secondary compile testing via ExtUtils::CBuilder
+sub can_xs {
+	# Do we have the configure_requires checker?
+	local $@;
+	eval "require ExtUtils::CBuilder;";
+	if ( $@ ) {
+		# They don't obey configure_requires, so it is
+		# someone old and delicate. Try to avoid hurting
+		# them by falling back to an older simpler test.
+		return can_cc();
+	}
+
+	# Do a simple compile that consumes the headers we need
+	my $object = undef;
+	my @libs   = ();
+	eval {
+		my $builder = ExtUtils::CBuilder->new( quiet => 1 );
+		unless ( $builder->have_compiler ) {
+			# Simple lack of a compiler at all
+			return 0;
+		}
+		$object = $builder->compile(
+			source => 'sanexs.c',
+		);
+		@libs = $builder->link(
+			objects     => $object,
+			module_name => 'sanexs',
+		);
+	};
+	my $broken = !! $@;
+	foreach ( $object, @libs ) {
+		next unless defined $_;
+		1 while unlink $_;
+	}
+
+	if ( $broken ) {
+		### NOTE: Don't do this in a production release.
+		# Compiler is officially screwed, you don't deserve
+		# to do any of our downstream depedencies as you'll
+		# probably end up choking on them as well.
+		# Trigger an NA for their own protection.
+		print "Unresolvable broken external dependency.\n";
+		print "This package requires a C compiler with full perl headers.\n";
+		print "Trivial test code using them failed to compile.\n";
+		print STDERR "NA: Unable to build distribution on this platform.\n";
+		exit(0);
+	}
+
+	return 1;
 }
 
 sub can_cc {

Modified: branches/upstream/liblist-moreutils-perl/current/MoreUtils.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/MoreUtils.xs?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/MoreUtils.xs (original)
+++ branches/upstream/liblist-moreutils-perl/current/MoreUtils.xs Thu Jun  2 15:38:56 2011
@@ -573,7 +573,6 @@
     OUTPUT:
 	RETVAL
 
-#if 0
 void
 apply (code, ...)
     SV *code;
@@ -603,11 +602,12 @@
     }
     POP_MULTICALL;
 
+    for(i = 1 ; i < items ; ++i)
+        sv_2mortal(args[i-1]);
+
     done:
     XSRETURN(items-1);
 }
-
-#endif
 
 void
 after (code, ...)
@@ -754,7 +754,6 @@
     XSRETURN(i-1);
 }
 
-#if 0
 void
 indexes (code, ...)
     SV *code;
@@ -779,22 +778,20 @@
     for (i = 1, j = 0; i < items; i++) {
 	GvSV(PL_defgv) = args[i];
 	MULTICALL;
-	if (SvTRUE(*PL_stack_sp)) {
-	    args[j] = sv_2mortal(newSViv(i-1));
-	    /* need to artificially increase ref-count here
-	     * because POPBLOCK further below would otherwise
-	     * free the items in SP */
-	    SvREFCNT_inc(args[j]);
-	    j++;
-	}
+	if (SvTRUE(*PL_stack_sp))
+            /* POP_MULTICALL can free mortal temporaries, so we defer
+             * mortalising the returned values till after that's been
+             * done */
+	    args[j++] = newSViv(i-1);
     }
     
     POP_MULTICALL;
-    
+
+    for (i = 0; i < j; i++)
+        sv_2mortal(args[i]);
+
     XSRETURN(j);
 }
-
-#endif
 
 SV *
 lastval (code, ...)
@@ -895,7 +892,6 @@
 	    AV *av = args->avs[i];
 	    if (args->curidx <= av_len(av)) {
 		ST(i) = sv_2mortal(newSVsv(*av_fetch(av, args->curidx, FALSE)));
-		SvREFCNT_inc(ST(i));
 		exhausted = 0;
 		continue;
 	    }
@@ -1055,7 +1051,6 @@
 	    for (j = nret-1; j >= 0; j--) {
 		/* POPs would return elements in reverse order */
 		buf[d] = sp[-j];
-		SvREFCNT_inc(buf[d]);
 		d++;
 	    }
 	    sp -= nret;
@@ -1089,9 +1084,8 @@
 	EXTEND(SP, nret);
 
 	for (i = 0; i < args->natatime; i++) {
-	    if (args->nsvs) {
+	    if (args->curidx < args->nsvs) {
 		ST(i) = sv_2mortal(newSVsv(args->svs[args->curidx++]));
-		args->nsvs--;
 	    }
 	    else {
 		XSRETURN(i);
@@ -1168,7 +1162,8 @@
     {
 	register int i, count = 0;
 	HV *hv = newHV();
-	
+	sv_2mortal(newRV_noinc((SV*)hv));
+
 	/* don't build return list in scalar context */
 	if (GIMME == G_SCALAR) {
 	    for (i = 0; i < items; i++) {
@@ -1177,7 +1172,6 @@
 		    hv_store_ent(hv, ST(i), &PL_sv_yes, 0);
 		}
 	    }
-	    SvREFCNT_dec(hv);
 	    ST(0) = sv_2mortal(newSViv(count));
 	    XSRETURN(1);
 	}
@@ -1190,7 +1184,6 @@
 		hv_store_ent(hv, ST(i), &PL_sv_yes, 0);
 	    }
 	}
-	SvREFCNT_dec(hv);
 	XSRETURN(count);
     }
 
@@ -1272,7 +1265,6 @@
 	XSRETURN(2);
     }
 
-#if 0
 void
 part (code, ...)
     SV *code;
@@ -1322,18 +1314,15 @@
 
     EXTEND(SP, last);
     for (i = 0; i < last; ++i) {
-	if (!tmp[i]) {
-	    ST(i) = &PL_sv_undef;
-	    continue;
-	}
-	ST(i) = newRV_noinc((SV*)tmp[i]);
+        if (tmp[i])
+            ST(i) = sv_2mortal(newRV_noinc((SV*)tmp[i]));
+        else
+            ST(i) = &PL_sv_undef;
     }
     
     Safefree(tmp);
     XSRETURN(last);
 }
-
-#endif
 
 #if 0
 void

Modified: branches/upstream/liblist-moreutils-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/README?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/README (original)
+++ branches/upstream/liblist-moreutils-perl/current/README Thu Jun  2 15:38:56 2011
@@ -35,22 +35,23 @@
 
     all BLOCK LIST
         Returns a true value if all items in LIST meet the criterion given
-        through BLOCK. Sets $_ for each item in LIST in turn:
+        through BLOCK, or if LIST is empty. Sets $_ for each item in LIST in
+        turn:
 
             print "All items defined"
                 if all { defined($_) } @list;
 
-        Returns false otherwise, or if LIST is empty.
+        Returns false otherwise.
 
     none BLOCK LIST
         Logically the negation of "any". Returns a true value if no item in
-        LIST meets the criterion given through BLOCK. Sets $_ for each item
-        in LIST in turn:
+        LIST meets the criterion given through BLOCK, or if LIST is empty.
+        Sets $_ for each item in LIST in turn:
 
             print "No value defined"
                 if none { defined($_) } @list;
 
-        Returns false otherwise, or if LIST is empty.
+        Returns false otherwise.
 
     notall BLOCK LIST
         Logically the negation of "all". Returns a true value if not all
@@ -220,7 +221,7 @@
         Like each_array, but the arguments are references to arrays, not the
         plain arrays.
 
-    natatime BLOCK LIST
+    natatime EXPR, LIST
         Creates an array iterator, for looping over an array in chunks of $n
         items at a time. (n at a time, get it?). An example is probably a
         better explanation than I could give in words.
@@ -428,9 +429,13 @@
     List::Util
 
 AUTHOR
+    Adam Kennedy <adamk at cpan.org>
+
     Tassilo von Parseval <tassilo.von.parseval at rwth-aachen.de>
 
 COPYRIGHT AND LICENSE
+    Some parts copyright 2011 Aaron Crane.
+
     Copyright 2004 - 2010 by Tassilo von Parseval
 
     This library is free software; you can redistribute it and/or modify it

Modified: branches/upstream/liblist-moreutils-perl/current/lib/List/MoreUtils.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/lib/List/MoreUtils.pm?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/lib/List/MoreUtils.pm (original)
+++ branches/upstream/liblist-moreutils-perl/current/lib/List/MoreUtils.pm Thu Jun  2 15:38:56 2011
@@ -7,7 +7,8 @@
 
 use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS };
 BEGIN {
-    $VERSION   = '0.30';
+    $VERSION   = '0.32';
+    # $VERSION   = eval $VERSION;
     @ISA       = qw{ Exporter DynaLoader };
     @EXPORT_OK = qw{
         any all none notall true false
@@ -38,31 +39,6 @@
     } unless $ENV{LIST_MOREUTILS_PP};
 }
 
-# Always use Perl apply() until memory leaks are resolved.
-sub apply (&@) {
-    my $action = shift;
-    &$action foreach my @values = @_;
-    wantarray ? @values : $values[-1];
-}
-
-# Always use Perl part() until memory leaks are resolved.
-sub part (&@) {
-    my ($code, @list) = @_;
-    my @parts;
-    push @{ $parts[ $code->($_) ] }, $_  foreach @list;
-    return @parts;
-}
-
-# Always use Perl indexes() until memory leaks are resolved.
-sub indexes (&@) {
-    my $test = shift;
-    grep {
-        local *_ = \$_[$_];
-        $test->()
-    } 0 .. $#_;
-}
-
-# Load the pure-Perl versions of the other functions if needed
 eval <<'END_PERL' unless defined &any;
 
 # Use pure scalar boolean return values for compatibility with XS
@@ -166,6 +142,12 @@
         @{$list}[ $c + 1 .. $#$list ],
     ) and return 1 if $c != -1;
     return 0;
+}
+
+sub apply (&@) {
+    my $action = shift;
+    &$action foreach my @values = @_;
+    wantarray ? @values : $values[-1];
 }
 
 sub after (&@) {
@@ -202,6 +184,14 @@
     }, @_;
 }
 
+sub indexes (&@) {
+    my $test = shift;
+    grep {
+        local *_ = \$_[$_];
+        $test->()
+    } 0 .. $#_;
+}
+
 sub lastval (&@) {
     my $test = shift;
     my $ix;
@@ -341,6 +331,13 @@
     }
 
     return ($min, $max);
+}
+
+sub part (&@) {
+    my ($code, @list) = @_;
+    my @parts;
+    push @{ $parts[ $code->($_) ] }, $_  foreach @list;
+    return @parts;
 }
 
 sub _XScompiled {
@@ -408,22 +405,23 @@
 =item all BLOCK LIST
 
 Returns a true value if all items in LIST meet the criterion given through
-BLOCK. Sets C<$_> for each item in LIST in turn:
+BLOCK, or if LIST is empty. Sets C<$_> for each item in LIST in turn:
 
     print "All items defined"
         if all { defined($_) } @list;
 
-Returns false otherwise, or if LIST is empty.
+Returns false otherwise.
 
 =item none BLOCK LIST
 
 Logically the negation of C<any>. Returns a true value if no item in LIST meets
-the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn:
+the criterion given through BLOCK, or if LIST is empty. Sets C<$_> for each item
+in LIST in turn:
 
     print "No value defined"
         if none { defined($_) } @list;
 
-Returns false otherwise, or if LIST is empty.
+Returns false otherwise.
 
 =item notall BLOCK LIST
 
@@ -608,7 +606,7 @@
 Like each_array, but the arguments are references to arrays, not the
 plain arrays.
 
-=item natatime BLOCK LIST
+=item natatime EXPR, LIST
 
 Creates an array iterator, for looping over an array in chunks of
 C<$n> items at a time.  (n at a time, get it?).  An example is
@@ -834,9 +832,13 @@
 
 =head1 AUTHOR
 
+Adam Kennedy E<lt>adamk at cpan.orgE<gt>
+
 Tassilo von Parseval E<lt>tassilo.von.parseval at rwth-aachen.deE<gt>
 
 =head1 COPYRIGHT AND LICENSE
+
+Some parts copyright 2011 Aaron Crane.
 
 Copyright 2004 - 2010 by Tassilo von Parseval
 

Added: branches/upstream/liblist-moreutils-perl/current/sanexs.c
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/sanexs.c?rev=75049&op=file
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/sanexs.c (added)
+++ branches/upstream/liblist-moreutils-perl/current/sanexs.c Thu Jun  2 15:38:56 2011
@@ -1,0 +1,11 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+    return 0;
+}
+
+int boot_sanexs() {
+    return 1;
+}

Modified: branches/upstream/liblist-moreutils-perl/current/t/lib/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/t/lib/Test.pm?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/t/lib/Test.pm (original)
+++ branches/upstream/liblist-moreutils-perl/current/t/lib/Test.pm Thu Jun  2 15:38:56 2011
@@ -7,7 +7,7 @@
 
 # Run all tests
 sub run {
-    plan tests => 154;
+    plan tests => 184;
 
     test_any();
     test_all();
@@ -55,6 +55,15 @@
     is_false( any { not defined } @list );
     is_true( any { not defined } undef );
     is_false( any { } );
+
+    leak_free_ok(any => sub {
+        my $ok = any { $_ == 5000 } @list;
+        my $ok2 = any { $_ == 5000 } 1 .. 10000;
+    });
+    leak_free_ok('any with a coderef that dies' => sub {
+        # This test is from Kevin Ryde; see RT#48669
+        eval { my $ok = any { die } 1 };
+    });
 }
 
 sub test_all {
@@ -64,6 +73,11 @@
     is_true( all { $_ > 0 } @list );
     is_false( all { $_ < 5000 } @list );
     is_true( all { } );
+
+    leak_free_ok(all => sub {
+        my $ok  = all { $_ == 5000 } @list;
+        my $ok2 = all { $_ == 5000 } 1 .. 10000;
+    });
 }
 
 sub test_none {
@@ -73,6 +87,11 @@
     is_true( none { $_ > 10000 } @list );
     is_false( none { defined } @list );
     is_true( none { } );
+
+    leak_free_ok(none => sub {
+        my $ok  = none { $_ == 5000 } @list;
+        my $ok2 = none { $_ == 5000 } 1 .. 10000;
+    });
 }
 
 sub test_notall {
@@ -82,6 +101,11 @@
     is_true( notall { $_ < 10000 } @list );
     is_false( notall { $_ <= 10000 } @list );
     is_false( notall { } );
+
+    leak_free_ok(notall => sub {
+        my $ok  = notall { $_ == 5000 } @list;
+        my $ok2 = notall { $_ == 5000 } 1 .. 10000;
+    });
 }
 
 sub test_true {
@@ -96,6 +120,11 @@
     is( 10000, true { defined } @list );
     is( 0, true { not defined } @list );
     is( 1, true { $_ == 5000 } @list );
+
+    leak_free_ok(true => sub {
+        my $n  = true { $_ == 5000 } @list;
+        my $n2 = true { $_ == 5000 } 1 .. 10000;
+    });
 }
 
 sub test_false {
@@ -110,6 +139,11 @@
     is( 10000, false { not defined } @list );
     is( 0, false { defined } @list );
     is( 1, false { $_ > 1 } @list );
+
+    leak_free_ok(false => sub {
+        my $n  = false { $_ == 5000 } @list;
+        my $n2 = false { $_ == 5000 } 1 .. 10000;
+    });
 }
 
 sub test_firstidx {
@@ -124,6 +158,11 @@
     is( -1, first_index { not defined } @list );
     is( 0, first_index { defined } @list );
     is( -1, first_index { } );
+
+    leak_free_ok(firstidx => sub {
+        my $i = firstidx { $_ >= 5000 } @list;
+        my $i2 = firstidx { $_ >= 5000 } 1 .. 10000;
+    });
 }
 
 sub test_lastidx {
@@ -138,6 +177,11 @@
     is( -1, last_index { not defined } @list );
     is( 9999, last_index { defined } @list );
     is( -1, last_index { } );
+
+    leak_free_ok(lastidx => sub {
+        my $i = lastidx { $_ >= 5000 } @list;
+        my $i2 = lastidx { $_ >= 5000 } 1 .. 10000;
+    });
 }
 
 sub test_insert_after {
@@ -152,6 +196,11 @@
     insert_after { not defined($_) } "longer" => @list;
     $list[2] = "a";
     is( join(' ', @list), "This is a longer list" );
+
+    leak_free_ok(insert_after => sub {
+        @list = qw{This is a list};
+        insert_after { $_ eq 'a' } "longer" => @list;
+    });
 }
 
 sub test_insert_after_string {
@@ -165,6 +214,11 @@
     @list = ( "This\0", "is\0", "a\0", "list\0" );
     insert_after_string "a\0", "longer\0", @list;
     is( join(' ', @list), "This\0 is\0 a\0 longer\0 list\0" );
+
+    leak_free_ok(insert_after_string => sub {
+        @list = qw{This is a list};
+        insert_after_string "a", "longer", @list;
+    });
 }
 
 sub test_apply {
@@ -197,6 +251,14 @@
         ok( arrayeq( \@list, [ 1 .. 4 ] ) );
         ok( arrayeq( \@list1, [ ( 5 ) x 4 ] ) );
     }
+
+    leak_free_ok(apply => sub {
+        @list = ( 1 .. 4 );
+        @list1 = apply {
+            grow_stack();
+            $_ = 5;
+        } @list;
+    });
 }
 
 sub test_indexes {
@@ -204,6 +266,11 @@
     ok( arrayeq( \@x, [ 2..5 ] ) );
     @x = indexes { $_ > 5 } ( 1 .. 4 );
     is_deeply( \@x, [ ], 'Got the null list' );
+
+    leak_free_ok(indexes => sub {
+        @x = indexes { $_ > 5 } ( 4 .. 9 );
+        @x = indexes { $_ > 5 } ( 1 .. 4 );
+    });
 }
 
 # In the following, the @dummy variable is needed to circumvent
@@ -215,6 +282,10 @@
     is_deeply( \@x, [ ], 'Got the null list' );
     @x = before { /f/ } @dummy = qw{ bar baz foo };
     ok( arrayeq( \@x, [ qw{ bar baz } ] ) );
+
+    leak_free_ok(before => sub {
+        @x = before { /f/ } @dummy = qw{ bar baz foo };
+    });
 }
 
 # In the following, the @dummy variable is needed to circumvent
@@ -226,6 +297,10 @@
     ok( arrayeq( \@x, [ qw{ bar baz } ] ) );
     @x = before_incl { /f/ } @dummy = qw{ bar baz foo };
     ok( arrayeq( \@x, [ qw{ bar baz foo } ] ) );
+
+    leak_free_ok(before_incl => sub {
+        @x = before_incl { /z/ } @dummy = qw{ bar baz foo };
+    });
 }
 
 # In the following, the @dummy variable is needed to circumvent
@@ -237,6 +312,10 @@
     is_deeply( \@x, [ ], 'Got the null list' );
     @x = after { /b/ } @dummy = qw{ bar baz foo };
     ok( arrayeq( \@x, [ qw{ baz foo } ] ) );
+
+    leak_free_ok(after => sub {
+        @x = after { /z/ } @dummy = qw{ bar baz foo };
+    });
 }
 
 # In the following, the @dummy variable is needed to circumvent
@@ -248,6 +327,10 @@
     is_deeply( \@x, [ ], 'Got the null list' );
     @x = after_incl { /b/ } @dummy = qw{ bar baz foo };
     ok( arrayeq( \@x, [ qw{ bar baz foo } ] ) );
+
+    leak_free_ok(after_incl => sub {
+        @x = after_incl { /z/ } @dummy = qw{ bar baz foo };
+    });
 }
 
 sub test_firstval {
@@ -261,6 +344,10 @@
     is( $x, 6 );
     $x = first_value { $_ > 5 }  1..4;
     is( $x, undef );
+
+    leak_free_ok(firstval => sub {
+        $x = firstval { $_ > 5 } 4 .. 9;
+    });
 }
 
 sub test_lastval {
@@ -274,6 +361,10 @@
     is( $x, 9 );
     $x = last_value { $_ > 5 }  1..4;
     is( $x, undef );
+
+    leak_free_ok(lastval => sub {
+        $x = lastval { $_ > 5 } 4 .. 9;
+    });
 }
 
 sub test_each_array {
@@ -362,6 +453,24 @@
         ok( arrayeq( \@a, [ 1, 3, 5 ] ) );
         ok( arrayeq( \@b, [ 2, 4, 6 ] ) );
     }
+
+    # Note that the leak_free_ok tests for each_array and each_arrayref
+    # should not be run until either of them has been called at least once
+    # in the current perl.  That's because calling them the first time
+    # causes the runtime to allocate some memory used for the OO structures
+    # that their implementation uses internally.
+    leak_free_ok(each_array => sub {
+        my @a = (1);
+        my $it = each_array @a;
+        while ( my ($a) = $it->() ) {
+        }
+    });
+    leak_free_ok(each_arrayref => sub {
+        my @a = (1);
+        my $it = each_arrayref \@a;
+        while ( my ($a) = $it->() ) {
+        }
+    });
 }
 
 sub test_pairwise {
@@ -425,6 +534,12 @@
     # Test that a die inside the code-reference will not be trapped
     eval { pairwise { die "I died\n" } @a, @b };
     is( $@, "I died\n" );
+
+    leak_free_ok(pairwise => sub {
+        @a = (1);
+        @b = (2);
+        @c = pairwise { $a + $b } @a, @b;
+    });
 }
 
 sub test_natatime {
@@ -444,6 +559,14 @@
         push @r, @vals;
     }
     is( arrayeq( \@r, \@a ), 1, "natatime2" );
+
+    leak_free_ok(natatime => sub {
+        my @y = 1;
+        my $it = natatime 2, @y;
+        while ( my @vals = $it->() ) {
+            # do nothing
+        }
+    });
 }
 
 sub test_zip {
@@ -475,6 +598,12 @@
             ] )
         );
     }
+
+    leak_free_ok(zip => sub {
+        my @x = qw/a b c d/;
+        my @y = qw/1 2 3 4/;
+        my @z = zip @x, @y;
+    });
 }
 
 sub test_mesh {
@@ -506,6 +635,12 @@
             ] )
         );
     }
+
+    leak_free_ok(mesh => sub {
+        my @x = qw/a b c d/;
+        my @y = qw/1 2 3 4/;
+        my @z = mesh @x, @y;
+    });
 }
 
 sub test_uniq {
@@ -536,6 +671,23 @@
         # is_deeply( [ uniq @foo ], \@foo, 'undef is supported correctly' );
         # is_deeply( \@warnings, [ ], 'No warnings during uniq check' );
     # }
+
+    leak_free_ok(uniq => sub {
+        my @a = map { ( 1 .. 1000 ) } 0 .. 1;
+        my @u = uniq @a;
+    });
+
+    # This test (and the associated fix) are from Kevin Ryde; see RT#49796
+    leak_free_ok('uniq with exception in overloading stringify', sub {
+        eval {
+            my $obj = DieOnStringify->new;
+            my @u = uniq $obj, $obj;
+        };
+        eval {
+            my $obj = DieOnStringify->new;
+            my $u = uniq $obj, $obj;
+        };
+    });
 }
 
 sub test_part {
@@ -578,6 +730,17 @@
     foreach ( 1 .. 10 ) {
         ok( arrayeq($list[$_], [ $_ ]) );
     }
+
+    leak_free_ok(part => sub {
+        my @list = 1 .. 12;
+        my $i    = 0;
+        my @part = part { $i++ % 3 } @list;
+    });
+
+    leak_free_ok('part with stack-growing' => sub {
+        # This test is from Kevin Ryde; see RT#38699
+        my @part = part { grow_stack(); 1024 } 'one', 'two';
+    });
 }
 
 sub test_minmax {
@@ -612,6 +775,11 @@
     is( $max, -1 );
     $min = 2;
     is( $max, -1 );
+
+    leak_free_ok(minmax => sub {
+        @list = ( 0, -1.1, 3.14, 1 / 7, 10000, -10 / 3 );
+        ($min, $max) = minmax @list;
+    });
 }
 
 
@@ -654,4 +822,21 @@
     return 1;
 }
 
+sub leak_free_ok {
+    my $name = shift;
+    my $code = shift;
+    SKIP: {
+        skip 'Test::LeakTrace not installed', 1
+            unless eval { require Test::LeakTrace; 1 };
+        &Test::LeakTrace::no_leaks_ok($code, "No memory leaks in $name");
+    }
+}
+
+{
+    package DieOnStringify;
+    use overload '""' => \&stringify;
+    sub new { bless {}, shift }
+    sub stringify { die 'DieOnStringify exception' }
+}
+
 1;

Modified: branches/upstream/liblist-moreutils-perl/current/xt/pmv.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/liblist-moreutils-perl/current/xt/pmv.t?rev=75049&op=diff
==============================================================================
--- branches/upstream/liblist-moreutils-perl/current/xt/pmv.t (original)
+++ branches/upstream/liblist-moreutils-perl/current/xt/pmv.t Thu Jun  2 15:38:56 2011
@@ -9,7 +9,7 @@
 }
 
 my @MODULES = (
-	'Perl::MinimumVersion 1.25',
+	'Perl::MinimumVersion 1.27',
 	'Test::MinimumVersion 0.101080',
 );
 




More information about the Pkg-perl-cvs-commits mailing list