ext/List/Util/t/first.t List::Util
ext/List/Util/t/isvstring.t Scalar::Util
ext/List/Util/t/lln.t Scalar::Util
-ext/List/Util/t/maxstr.t List::Util
ext/List/Util/t/max.t List::Util
-ext/List/Util/t/minstr.t List::Util
+ext/List/Util/t/maxstr.t List::Util
ext/List/Util/t/min.t List::Util
+ext/List/Util/t/minstr.t List::Util
ext/List/Util/t/openhan.t Scalar::Util
+ext/List/Util/t/p_blessed.t Scalar::Util
+ext/List/Util/t/p_first.t List::Util
+ext/List/Util/t/p_lln.t Scalar::Util
+ext/List/Util/t/p_max.t List::Util
+ext/List/Util/t/p_maxstr.t List::Util
+ext/List/Util/t/p_min.t List::Util
+ext/List/Util/t/p_minstr.t List::Util
+ext/List/Util/t/p_openhan.t Scalar::Util
+ext/List/Util/t/p_readonly.t Scalar::Util
+ext/List/Util/t/p_reduce.t List::Util
+ext/List/Util/t/p_refaddr.t Scalar::Util
+ext/List/Util/t/p_reftype.t Scalar::Util
+ext/List/Util/t/p_shuffle.t List::Util
+ext/List/Util/t/p_sum.t List::Util
+ext/List/Util/t/p_tainted.t Scalar::Util
ext/List/Util/t/proto.t Scalar::Util
ext/List/Util/t/readonly.t Scalar::Util
ext/List/Util/t/reduce.t List::Util
+1.15 -- Fri May 13 11:01:15 CDT 2005
+
+Bug Fixes
+ * Fixed memory leak in first()
+
+Enhancements
+ * Converted tests to use Test::More
+ * Improved test coverage
+ * Changed Makefile.PL to use Module::Install
+ * Refactor use of Sv..X() macros to be Sv.._set()
+ * Changes from Jarkko for Symbian port of Perl
+ * Documentation updates to weaken()
+
1.14 -- Sat May 22 08:01:19 BST 2004
Bug Fixes
* Fixed looks_like_number(undef) to return false for perl >= 5.009002
* Fixed bug in refaddr() when passed a tied variable
-ChangeLogs for releases prior to 1.14 may be found at
-http://svn.mutatus.co.uk/browse/Scalar-List-Utils/tags/Scalar-List-Utils-1.13/ChangeLog
+Switch to svn repository at http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/
+Old perforce revision log below
+
+Change 827 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.13
+
+Change 826 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix NV casting issue with some compilers
+
+Change 825 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.12
+
+Change 824 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Don't directly use the SV returned as $a in the next iteration,
+ take a copy instead. Fixes problem if the code block result was from
+ an eval or sub call
+
+Change 823 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Install into the 'perl' installdirs for >= 5.008
+
+Change 822 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix test for EBCDIC portability
+
+Change 771 on 2003/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Get path for make from $Config
+
+Change 770 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.11
+
+Change 769 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Add t/proto.t to MANIFEST
+
+Change 768 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Add set_prototype from Rafael Garcia-Suarez
+
+Change 767 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix t/isvstring.t so it does not cause perl5.004 to segv
+ because of the exit from within BEGIN
+
+Change 766 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Change how patchlevel.h is included and check we got what we wanted (from Jarkko)
+
+Change 765 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1
+
+Change 764 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.10
+
+Change 763 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix linking error for older perls
+
+Change 762 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Make lln tests and perl implementation mimic changes to looks_like_number
+ in different perl versions
+
+Change 761 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Add looks_like_number
+
+Change 760 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Ensure PERL_DL_NONLAZY is false so we don't catch link errors during
+ bootstrap and then test the perl only version
+
+Change 759 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.09
+
+Change 758 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr)
+
+ Use UV to return refaddr
+
+Change 757 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Add XS_VERSION
+
+Change 756 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Use PAD_* macros in 5.9
+ Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad
+
+Change 751 on 2002/10/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix context so that sub for reduce/first is always in a scalar context
+ Fix sum/min/max so that they don't upgrade their arguments to NVs
+ if they are IV or UV
+
+Change 750 on 2002/10/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Add isvstring()
+
+Change 745 on 2002/09/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Scalar::Util
+ - Add refaddr()
+
+Change 722 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.0701
+
+Change 721 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
+
+ Add comment to README about failing tests on perl5.6.0
+
+Change 714 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.07
+
+Change 713 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Add Scalar::Util::openhandle()
+
+Change 647 on 2001/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.06
+
+Change 645 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Some platforms require the main executable to export symbols
+ needed by modules. In 5.7.2 and prior releases of perl
+ Perl_cxinc was not exported so we need to duplicate its
+ functionality
+
+Change 644 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Generate a typemap for NV for all perl version up to and
+ including 5.006
+
+Change 643 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Document problems known with specific versions of perl
+
+Change 642 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.05
+
+Change 641 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix shuffle() to compile with threaded perl
+
+Change 640 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.04
+
+Change 639 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix context type (caused a core on Tru64)
+ Call pp_rand via *(PL_ppaddr[OP_RAND])
+
+Change 638 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Documentation updates
+
+Change 637 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.03
+
+Change 636 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+ More changes to help merging with core dist
+
+Change 635 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Added List::Util::shuffle() similar to that described in
+ the perl FAQ except it returns a shuffled list instead of
+ modifying an array passed by reference
+
+Change 632 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Handle tied variables passed for the number to dualvar()
+ Preserve number type (IV/UV/NV) in dualvar()
+
+Change 631 on 2001/08/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Handle eval{} inside of the code blocks for first and reduce
+
+Change 629 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
+
+ perl5.004 does not like exit from within a BEGIN, it core dumps
+
+Change 628 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix stack problem in first() and reduce()
+ Align with core dist
+
+Change 483 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.02
+
+Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Check for SvMAGICAL on argument for reftype and blessed
+
+Change 366 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.01
+
+Change 365 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added auto-detection for a compiler and install the perl version
+ if not found
+ - Better perl implemenation of reftype, should be thread-safe now
+
+Change 364 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added some examples of simple subs that have been requested
+ but not added
+ - Updated copyright dates
+
+Change 344 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Better testcase for reftype
+
+Change 343 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Modules are now called List::Util & Scalar::Util
+ - Supports non-XS install
+ - perl version of reftype now returns "REF" when it should
+
+Change 311 on 1999/06/01 by <gbarr@pobox.com> (Graham Barr)
+
+ Updated README
+
+Change 275 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Removed forall as it is very broken
+
+Change 274 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Added List::Util::forall
+
+Change 273 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Added weaken and isweak to Ref::Util
+
+Change 272 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Add new .pm files to repository
+
+Change 271 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Split into three packages Ref::Util, List::Util and Scalar::DualVar
+ - readonly and clock were removed in favor of other modules
+
+Change 270 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Rename package
+
+Change 269 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added reftype
+ - improved reduce by not doing a sub call
+ - reduce now uses $a and $b
+ - now compiles with 5.005_5x
+
+Change 178 on 1998/07/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Modified XS code so it will compile with 5.004 and 5.005
+
+Change 115 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Fri Feb 20 1998 Graham Barr <gbarr@pobox.com>
+
+ t/min.t, t/max.t
+ - Change sor to do a numerical sort
+
+ Fri Dec 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Added readonly()
+
+ Wed Nov 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Initial release
+
# define PTR2UV(ptr) (UV)(ptr)
#endif
+#ifndef SvUV_set
+# define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val))
+#endif
+
#ifdef HASATTRIBUTE
# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
# define PERL_UNUSED_DECL
}
ST(0) = ret;
POPBLOCK(cx,PL_curpm);
- LEAVESUB(cv);
CATCH_SET(oldcatch);
XSRETURN(1);
}
if (SvTRUE(*PL_stack_sp)) {
ST(0) = ST(index);
POPBLOCK(cx,PL_curpm);
- LEAVESUB(cv);
CATCH_SET(oldcatch);
XSRETURN(1);
}
}
POPBLOCK(cx,PL_curpm);
- LEAVESUB(cv);
CATCH_SET(oldcatch);
XSRETURN_UNDEF;
}
# List::Util.pm
#
-# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@ISA = qw(Exporter);
@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION = "1.14_01";
+$VERSION = "1.15";
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 COPYRIGHT
-Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# Scalar::Util.pm
#
-# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@ISA = qw(Exporter);
@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
-$VERSION = "1.14_1";
+$VERSION = "1.15";
$VERSION = eval $VERSION;
sub export_fail {
}
# $ref is now undef
+Note that if you take a copy of a scalar with a weakened reference,
+the copy will be a strong reference.
+
+ my $var;
+ my $foo = \$var;
+ weaken($foo); # Make $foo a weak reference
+ my $bar = $foo; # $bar is now a strong reference
+
+This may be less obvious in other situations, such as C<grep()>, for instance
+when grepping through a list of weakened references to objects that may have
+been destroyed already:
+
+ @object = grep { defined } @object;
+
+This will indeed remove all references to destroyed objects, but the remaining
+references to objects will be strong, causing the remaining objects to never
+be destroyed because there is now always a strong reference to them in the
+@object array.
+
=back
=head1 KNOWN BUGS
=head1 COPYRIGHT
-Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
}
}
+use Test::More tests => 8;
use Scalar::Util qw(blessed);
-use vars qw($t $y $x);
+use vars qw($t $x);
-print "1..7\n";
-
-print "not " if blessed(1);
-print "ok 1\n";
-
-print "not " if blessed('A');
-print "ok 2\n";
-
-print "not " if blessed({});
-print "ok 3\n";
-
-print "not " if blessed([]);
-print "ok 4\n";
-
-$y = \$t;
-
-print "not " if blessed($y);
-print "ok 5\n";
+ok(!blessed(undef), 'undef is not blessed');
+ok(!blessed(1), 'Numbers are not blessed');
+ok(!blessed('A'), 'Strings are not blessed');
+ok(!blessed({}), 'Unblessed HASH-ref');
+ok(!blessed([]), 'Unblessed ARRAY-ref');
+ok(!blessed(\$t), 'Unblessed SCALAR-ref');
$x = bless [], "ABC";
+is(blessed($x), "ABC", 'blessed ARRAY-ref');
-print "not " unless blessed($x);
-print "ok 6\n";
-
-print "not " unless blessed($x) eq 'ABC';
-print "ok 7\n";
+$x = bless {}, "DEF";
+is(blessed($x), "DEF", 'blessed HASH-ref');
}
}
-use vars qw($skip);
+use Scalar::Util ();
+use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL)
+ ? (skip_all => 'dualvar requires XS version')
+ : (tests => 11);
-BEGIN {
- require Scalar::Util;
-
- if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
- print "1..0\n";
- $skip=1;
- }
-}
-
-eval <<'EOT' unless $skip;
-use Scalar::Util qw(dualvar);
-
-print "1..11\n";
-
-$var = dualvar 2.2,"string";
+Scalar::Util->import('dualvar');
-print "not " unless $var == 2.2;
-print "ok 1\n";
+$var = dualvar( 2.2,"string");
-print "not " unless $var eq "string";
-print "ok 2\n";
+ok( $var == 2.2, 'Numeric value');
+ok( $var eq "string", 'String value');
$var2 = $var;
+ok( $var2 == 2.2, 'copy Numeric value');
+ok( $var2 eq "string", 'copy String value');
+
$var++;
-print "not " unless $var == 3.2;
-print "ok 3\n";
+ok( $var == 3.2, 'inc Numeric value');
+ok( $var ne "string", 'inc String value');
-print "not " unless $var ne "string";
-print "ok 4\n";
+my $numstr = "10.2";
+my $numtmp = int($numstr); # use $numstr as an int
-print "not " unless $var2 == 2.2;
-print "ok 5\n";
+$var = dualvar($numstr, "");
-print "not " unless $var2 eq "string";
-print "ok 6\n";
+ok( $var == $numstr, 'NV');
-my $numstr = "10.2";
-my $numtmp = sprintf("%d", $numstr);
-$var = dualvar $numstr, "";
-print "not " unless $var == $numstr;
-print "ok 7\n";
-
-$var = dualvar 1<<31, "";
-print "not " unless $var == 1<<31;
-print "ok 8\n";
-print "not " unless $var > 0;
-print "ok 9\n";
+$var = dualvar(1<<31, "");
+ok( $var == (1<<31), 'UV 1');
+ok( $var > 0, 'UV 2');
tie my $tied, 'Tied';
-$var = dualvar $tied, "ok";
-print "not " unless $var == 7.5;
-print "ok 10\n";
-print "not " unless $var eq "ok";
-print "ok 11\n";
-
-EOT
+$var = dualvar($tied, "ok");
+ok($var == 7.5, 'Tied num');
+ok($var eq 'ok', 'Tied str');
package Tied;
}
}
+use Test::More tests => 8;
use List::Util qw(first);
+my $v;
-print "1..8\n";
+ok(defined &first, 'defined');
-print "not " unless defined &first;
-print "ok 1\n";
+$v = first { 8 == ($_ - 1) } 9,4,5,6;
+is($v, 9, 'one more than 8');
-print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6;
-print "ok 2\n";
+$v = first { 0 } 1,2,3,4;
+is($v, undef, 'none match');
-print "not " if defined(first { 0 } 1,2,3,4);
-print "ok 3\n";
+$v = first { 0 };
+is($v, undef, 'no args');
-print "not " if defined(first { 0 });
-print "ok 4\n";
-
-my $foo = first { $_->[1] le "e" and "e" le $_->[2] }
+$v = first { $_->[1] le "e" and "e" le $_->[2] }
[qw(a b c)], [qw(d e f)], [qw(g h i)];
-print "not " unless $foo->[0] eq 'd';
-print "ok 5\n";
+is_deeply($v, [qw(d e f)], 'reference args');
# Check that eval{} inside the block works correctly
my $i = 0;
-print "not " unless 5 == first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
-print "ok 6\n";
-
-print "not " if defined eval { first { die if $_ } 0,0,1 };
-print "ok 7\n";
+$v = first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
+is($v, 5, 'use of eval');
-($x) = foobar();
-$x = '' unless defined $x;
-print "${x}ok 8\n";
+$v = eval { first { die if $_ } 0,0,1 };
+is($v, undef, 'use of die');
sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " }
+($v) = foobar();
+is($v, undef, 'wantarray');
+
+
}
$|=1;
-require Scalar::Util;
-if (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) {
- print("1..0\n");
- exit 0;
-}
+use Scalar::Util ();
+use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL)
+ ? (skip_all => 'isvstring requires XS version')
+ : (tests => 3);
Scalar::Util->import(qw[isvstring]);
-print "1..4\n";
-
-print "ok 1\n";
-
$vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
-print "not " unless $vs == "1.0";
-print "ok 2\n";
-
-print "not " unless isvstring($vs);
-print "ok 3\n";
+ok( $vs == "1.0", 'dotted num');
+ok( isvstring($vs), 'isvstring');
$sv = "1.0";
-print "not " if isvstring($sv);
-print "ok 4\n";
+ok( !isvstring($sv), 'not isvstring');
#!/usr/bin/perl -w
-# -*- perl -*-
-
-
-#
-# $Id: $
-# Author: Slaven Rezic
-#
-
-use strict;
-use vars qw(%Config);
BEGIN {
unless (-d 'blib') {
}
}
+use strict;
+use Test::More tests => 12;
use Scalar::Util qw(looks_like_number);
-my $i;
-sub ok { print +(($_[0] eq $_[1]) ? "": "not "), "ok ",++$i,"\n" }
-
-print "1..12\n";
+foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) {
+ ok(looks_like_number($num), "'$num'");
+}
-ok(!!looks_like_number("1"), 1);
-ok(!!looks_like_number("-1"), 1);
-ok(!!looks_like_number("+1"), 1);
-ok(!!looks_like_number("1.0"), 1);
-ok(!!looks_like_number("+1.0"), 1);
-ok(!!looks_like_number("-1.0"), 1);
-ok(!!looks_like_number("-1.0e-12"), 1);
-ok(!!looks_like_number("Inf"), $] >= 5.006001);
-ok(!!looks_like_number("Infinity"), $] >= 5.008);
-ok(!!looks_like_number("NaN"), $] >= 5.008);
-ok(!!looks_like_number("foo"), '');
-ok(!!looks_like_number(undef), $] < 5.009002);
-# That's enough - we trust the perl core tests like t/base/num.t
+is(!!looks_like_number("Inf"), $] >= 5.006001, 'Inf');
+is(!!looks_like_number("Infinity"), $] >= 5.008, 'Infinity');
+is(!!looks_like_number("NaN"), $] >= 5.008, 'NaN');
+is(!!looks_like_number("foo"), '', 'foo');
+is(!!looks_like_number(undef), $] < 5.009002, 'undef');
-__END__
+# We should copy some of perl core tests like t/base/num.t here
}
}
-
+use strict;
+use Test::More tests => 5;
use List::Util qw(max);
-print "1..5\n";
+my $v;
-print "not " unless defined &max;
-print "ok 1\n";
+ok(defined &max, 'defined');
-print "not " unless max(1) == 1;
-print "ok 2\n";
+$v = max(1);
+is($v, 1, 'single arg');
-print "not " unless max(1,2) == 2;
-print "ok 3\n";
+$v = max (1,2);
+is($v, 2, '2-arg ordered');
-print "not " unless max(2,1) == 2;
-print "ok 4\n";
+$v = max(2,1);
+is($v, 2, '2-arg reverse ordered');
my @a = map { rand() } 1 .. 20;
my @b = sort { $a <=> $b } @a;
-print "not " unless max(@a) == $b[-1];
-print "ok 5\n";
+$v = max(@a);
+is($v, $b[-1], '20-arg random order');
}
}
-
+use strict;
+use Test::More tests => 5;
use List::Util qw(maxstr);
-print "1..5\n";
+my $v;
-print "not " unless defined &maxstr;
-print "ok 1\n";
+ok(defined &maxstr, 'defined');
-print "not " unless maxstr('a') eq 'a';
-print "ok 2\n";
+$v = maxstr('a');
+is($v, 'a', 'single arg');
-print "not " unless maxstr('a','b') eq 'b';
-print "ok 3\n";
+$v = maxstr('a','b');
+is($v, 'b', '2-arg ordered');
-print "not " unless maxstr('B','A') eq 'B';
-print "ok 4\n";
+$v = maxstr('B','A');
+is($v, 'B', '2-arg reverse ordered');
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
my @b = sort { $a cmp $b } @a;
-print "not " unless maxstr(@a) eq $b[-1];
-print "ok 5\n";
+$v = maxstr(@a);
+is($v, $b[-1], 'random ordered');
}
}
-
+use strict;
+use Test::More tests => 5;
use List::Util qw(min);
-print "1..5\n";
+my $v;
-print "not " unless defined &min;
-print "ok 1\n";
+ok(defined &min, 'defined');
-print "not " unless min(9) == 9;
-print "ok 2\n";
+$v = min(9);
+is($v, 9, 'single arg');
-print "not " unless min(1,2) == 1;
-print "ok 3\n";
+$v = min (1,2);
+is($v, 1, '2-arg ordered');
-print "not " unless min(2,1) == 1;
-print "ok 4\n";
+$v = min(2,1);
+is($v, 1, '2-arg reverse ordered');
my @a = map { rand() } 1 .. 20;
my @b = sort { $a <=> $b } @a;
-print "not " unless min(@a) == $b[0];
-print "ok 5\n";
+$v = min(@a);
+is($v, $b[0], '20-arg random order');
}
}
-
+use strict;
+use Test::More tests => 5;
use List::Util qw(minstr);
-print "1..5\n";
+my $v;
-print "not " unless defined &minstr;
-print "ok 1\n";
+ok(defined &minstr, 'defined');
-print "not " unless minstr('a') eq 'a';
-print "ok 2\n";
+$v = minstr('a');
+is($v, 'a', 'single arg');
-print "not " unless minstr('a','b') eq 'a';
-print "ok 3\n";
+$v = minstr('a','b');
+is($v, 'a', '2-arg ordered');
-print "not " unless minstr('B','A') eq 'A';
-print "ok 4\n";
+$v = minstr('B','A');
+is($v, 'A', '2-arg reverse ordered');
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
my @b = sort { $a cmp $b } @a;
-print "not " unless minstr(@a) eq $b[0];
-print "ok 5\n";
+$v = minstr(@a);
+is($v, $b[0], 'random ordered');
}
}
-
+use strict;
+use vars qw(*CLOSED);
+use Test::More tests => 4;
use Scalar::Util qw(openhandle);
-print "1..4\n";
-
-print "not " unless defined &openhandle;
-print "ok 1\n";
+ok(defined &openhandle, 'defined');
my $fh = \*STDERR;
-print "not " unless openhandle($fh) == $fh;
-print "ok 2\n";
+is(openhandle($fh), $fh, 'STDERR');
-print "not " unless fileno(openhandle(*STDERR)) == fileno(STDERR);
-print "ok 3\n";
+is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
-print "not " if openhandle(CLOSED);
-print "ok 4\n";
+is(openhandle(*CLOSED), undef, 'closed');
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
--- /dev/null
+#!./perl -T
+
+# force perl-only version to be tested
+sub List::Util::bootstrap {}
+
+(my $f = __FILE__) =~ s/p_//;
+do $f;
}
}
-BEGIN {
- require Scalar::Util;
-
- if (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) {
- print "1..0\n";
- $skip=1;
- }
-}
-
-eval <<'EOT' unless $skip;
-use Scalar::Util qw(set_prototype);
+use Scalar::Util ();
+use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
+ ? (skip_all => 'set_prototype requires XS version')
+ : (tests => 13);
-print "1..13\n";
-$test = 0;
-
-sub proto_is ($$) {
- $proto = prototype shift;
- $expected = shift;
- if (defined $expected) {
- print "# Got $proto, expected $expected\nnot " if $expected ne $proto;
- }
- else {
- print "# Got $proto, expected undef\nnot " if defined $proto;
- }
- print "ok ", ++$test, "\n";
-}
+Scalar::Util->import('set_prototype');
sub f { }
-proto_is 'f' => undef;
+is( prototype('f'), undef, 'no prototype');
+
$r = set_prototype(\&f,'$');
-proto_is 'f' => '$';
-print "not " unless ref $r eq "CODE" and $r == \&f;
-print "ok ", ++$test, " - return value\n";
+is( prototype('f'), '$', 'set prototype');
+is( $r, \&f, 'return value');
+
set_prototype(\&f,undef);
-proto_is 'f' => undef;
+is( prototype('f'), undef, 'remove prototype');
+
set_prototype(\&f,'');
-proto_is 'f' => '';
+is( prototype('f'), '', 'empty prototype');
sub g (@) { }
-proto_is 'g' => '@';
+is( prototype('g'), '@', '@ prototype');
+
set_prototype(\&g,undef);
-proto_is 'g' => undef;
+is( prototype('g'), undef, 'remove prototype');
-sub non_existent;
-proto_is 'non_existent' => undef;
-set_prototype(\&non_existent,'$$$');
-proto_is 'non_existent' => '$$$';
+sub stub;
+is( prototype('stub'), undef, 'non existing sub');
-sub forward_decl ($$$$);
-proto_is 'forward_decl' => '$$$$';
-set_prototype(\&forward_decl,'\%');
-proto_is 'forward_decl' => '\%';
+set_prototype(\&stub,'$$$');
+is( prototype('stub'), '$$$', 'change non existing sub');
+
+sub f_decl ($$$$);
+is( prototype('f_decl'), '$$$$', 'forward declaration');
+
+set_prototype(\&f_decl,'\%');
+is( prototype('f_decl'), '\%', 'change forward declaration');
eval { &set_prototype( 'f', '' ); };
-print "not " unless $@ =~ /^set_prototype: not a reference/;
-print "ok ", ++$test, " - error msg\n";
+print "not " unless
+ok($@ =~ /^set_prototype: not a reference/, 'not a reference');
+
eval { &set_prototype( \'f', '' ); };
-print "not " unless $@ =~ /^set_prototype: not a subroutine reference/;
-print "ok ", ++$test, " - error msg\n";
-EOT
+ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
}
use Scalar::Util qw(readonly);
+use Test::More tests => 9;
-
-print "1..9\n";
-
-print "not " unless readonly(1);
-print "ok 1\n";
+ok( readonly(1), 'number constant');
my $var = 2;
-print "not " if readonly($var);
-print "ok 2\n";
-
-print "not " unless $var == 2;
-print "ok 3\n";
+ok( !readonly($var), 'number variable');
+is( $var, 2, 'no change to number variable');
-print "not " unless readonly("fred");
-print "ok 4\n";
+ok( readonly("fred"), 'string constant');
$var = "fred";
-print "not " if readonly($var);
-print "ok 5\n";
-
-print "not " unless $var eq "fred";
-print "ok 6\n";
+ok( !readonly($var), 'string variable');
+is( $var, 'fred', 'no change to string variable');
$var = \2;
-print "not " if readonly($var);
-print "ok 7\n";
-
-print "not " unless readonly($$var);
-print "ok 8\n";
+ok( !readonly($var), 'reference to constant');
+ok( readonly($$var), 'de-reference to constant');
-print "not " if readonly(*STDOUT);
-print "ok 9\n";
+ok( !readonly(*STDOUT), 'glob');
use List::Util qw(reduce min);
+use Test::More tests => 14;
-print "1..13\n";
+my $v = reduce {};
-print "not " if defined reduce {};
-print "ok 1\n";
+is( $v, undef, 'no args');
-print "not " unless 9 == reduce { $a / $b } 756,3,7,4;
-print "ok 2\n";
+$v = reduce { $a / $b } 756,3,7,4;
+is( $v, 9, '4-arg divide');
-print "not " unless 9 == reduce { $a / $b } 9;
-print "ok 3\n";
+$v = reduce { $a / $b } 6;
+is( $v, 6, 'one arg');
@a = map { rand } 0 .. 20;
-print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a;
-print "ok 4\n";
+$v = reduce { $a < $b ? $a : $b } @a;
+is( $v, min(@a), 'min');
@a = map { pack("C", int(rand(256))) } 0 .. 20;
-print "not " unless join("",@a) eq reduce { $a . $b } @a;
-print "ok 5\n";
+$v = reduce { $a . $b } @a;
+is( $v, join("",@a), 'concat');
sub add {
my($aa, $bb) = @_;
return $aa + $bb;
}
-my $sum = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
-print "not " unless $sum == 6;
-print "ok 6\n";
+$v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
+is( $v, 6, 'call sub');
# Check that eval{} inside the block works correctly
-print "not " unless 10 == reduce { eval { die }; $a + $b } 0,1,2,3,4;
-print "ok 7\n";
+$v = reduce { eval { die }; $a + $b } 0,1,2,3,4;
+is( $v, 10, 'use eval{}');
-print "not " if defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
-print "ok 8\n";
+$v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
+ok($v, 'die');
-($x) = foobar();
-print "${x}ok 9\n";
-
-sub foobar { reduce { (defined(wantarray) && !wantarray) ? '' : 'not ' } 0,1,2,3 }
+sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
+($v) = foobar();
+is( $v, 3, 'scalar context');
sub add2 { $a + $b }
-print "not " unless 6 == reduce \&add2, 1,2,3;
-print "ok 10\n";
-
-print "not " unless 6 == reduce { add2() } 1,2,3;
-print "ok 11\n";
-
+$v = reduce \&add2, 1,2,3;
+is( $v, 6, 'sub reference');
-print "not " unless 6 == reduce { eval "$a + $b" } 1,2,3;
-print "ok 12\n";
+$v = reduce { add2() } 3,4,5;
+is( $v, 12, 'call sub');
-$a = $b = 9;
-reduce { $a * $b } 1,2,3;
-print "not " unless $a == 9 and $b == 9;
-print "ok 13\n";
+$v = reduce { eval "$a + $b" } 1,2,3;
+is( $v, 6, 'eval string');
+$a = 8; $b = 9;
+$v = reduce { $a * $b } 1,2,3;
+is( $a, 8, 'restore $a');
+is( $b, 9, 'restore $b');
}
+use Test::More tests => 19;
+
use Scalar::Util qw(refaddr);
use vars qw($t $y $x *F $v $r);
use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
-print "1..19\n";
-
my $i = 1;
foreach $v (undef, 10, 'string') {
- print "not " if defined refaddr($v);
- print "ok ",$i++,"\n";
+ is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef"));
}
foreach $r ({}, \$t, [], \*F, sub {}) {
my $addr = $r + 0;
- print "not " unless refaddr($r) == $addr;
- print "ok ",$i++,"\n";
+ my $n = "$r";
+ is( refaddr($r), $addr, $n);
+
my $obj = bless $r, 'FooBar';
- print "not " unless refaddr($r) == $addr;
- print "ok ",$i++,"\n";
+ is( refaddr($r), $addr, "blessed with overload $n");
}
{
$x{$b} = 23;
my $xy = $x{$y};
my $xb = $x{$b};
- print "not " unless ref($x{$y});
- print "ok ",$i++,"\n";
- print "not " unless ref($x{$b});
- print "ok ",$i++,"\n";
- print "not " unless refaddr($xy) == refaddr($y);
- print "ok ",$i++,"\n";
- print "not " unless refaddr($xb) == refaddr($b);
- print "ok ",$i++,"\n";
- print "not " unless refaddr($x{$y});
- print "ok ",$i++,"\n";
- print "not " unless refaddr($x{$b});
- print "ok ",$i++,"\n";
+ ok(ref($x{$y}));
+ ok(ref($x{$b}));
+ ok(refaddr($xy) == refaddr($y));
+ ok(refaddr($xb) == refaddr($b));
+ ok(refaddr($x{$y}));
+ ok(refaddr($x{$b}));
}
package FooBar;
}
}
+use Test::More tests => 23;
use Scalar::Util qw(reftype);
use vars qw($t $y $x *F);
tie *F, 'MyTie';
@test = (
- [ undef, 1],
- [ undef, 'A'],
- [ HASH => {} ],
- [ ARRAY => [] ],
- [ SCALAR => \$t ],
- [ REF => \(\$t) ],
- [ GLOB => \*F ],
- [ GLOB => gensym ],
- [ CODE => sub {} ],
+ [ undef, 1, 'number' ],
+ [ undef, 'A', 'string' ],
+ [ HASH => {}, 'HASH ref' ],
+ [ ARRAY => [], 'ARRAY ref' ],
+ [ SCALAR => \$t, 'SCALAR ref' ],
+ [ REF => \(\$t), 'REF ref' ],
+ [ GLOB => \*F, 'tied GLOB ref' ],
+ [ GLOB => gensym, 'GLOB ref' ],
+ [ CODE => sub {}, 'CODE ref' ],
# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
);
-print "1..", @test*4, "\n";
-
-my $i = 1;
foreach $test (@test) {
- my($type,$what) = @$test;
- my $pack;
- foreach $pack (undef,"ABC","0",undef) {
- print "# $what\n";
- my $res = reftype($what);
- printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res;
- print "not " if $type ? $res ne $type : defined($res);
- bless $what, $pack if $type && defined $pack;
- print "ok ",$i++,"\n";
- }
+ my($type,$what, $n) = @$test;
+
+ is( reftype($what), $type, $n);
+ next unless ref($what);
+
+ bless $what, "ABC";
+ is( reftype($what), $type, $n);
+
+ bless $what, "0";
+ is( reftype($what), $type, $n);
}
package MyTie;
}
}
+use Test::More tests => 6;
use List::Util qw(shuffle);
-print "1..5\n";
-
my @r;
@r = shuffle();
-print "not " if @r;
-print "ok 1\n";
+ok( !@r, 'no args');
@r = shuffle(9);
-print "not " unless @r == 1 and $r[0] = 9;
-print "ok 2\n";
+is( 0+@r, 1, '1 in 1 out');
+is( $r[0], 9, 'one arg');
my @in = 1..100;
@r = shuffle(@in);
-print "not " unless @r == @in;
-print "ok 3\n";
+is( 0+@r, 0+@in, 'arg count');
-print "not " if join("",@r) eq join("",@in);
-print "ok 4\n";
+isnt( "@r", "@in", 'result different to args');
-print "not " if join("",sort { $a <=> $b } @r) ne join("",@in);
-print "ok 5\n";
+my @s = sort { $a <=> $b } @r;
+is( "@in", "@s", 'values');
}
}
+use Test::More tests => 6;
use List::Util qw(sum);
-print "1..6\n";
+my $v = sum;
+is( $v, undef, 'no args');
-print "not " if defined sum;
-print "ok 1\n";
+$v = sum(9);
+is( $v, 9, 'one arg');
-print "not " unless sum(9) == 9;
-print "ok 2\n";
+$v = sum(1,2,3,4);
+is( $v, 10, '4 args');
-print "not " unless sum(1,2,3,4) == 10;
-print "ok 3\n";
-
-print "not " unless sum(-1) == -1;
-print "ok 4\n";
+$v = sum(-1);
+is( $v, -1, 'one -1');
my $x = -3;
-print "not " unless sum($x,3) == 0;
-print "ok 5\n";
+$v = sum($x, 3);
+is( $v, 0, 'variable arg');
-print "not " unless sum(-3.5,3) == -0.5;
-print "ok 6\n";
+$v = sum(-3.5,3);
+is( $v, -0.5, 'real numbers');
}
}
-use lib qw(blib/lib blib/arch);
-use Scalar::Util qw(tainted);
-use Config;
+use Test::More tests => 4;
-print "1..4\n";
+use Scalar::Util qw(tainted);
-print "not " if tainted(1);
-print "ok 1\n";
+ok( !tainted(1), 'constant number');
my $var = 2;
-print "not " if tainted($var);
-print "ok 2\n";
+ok( !tainted($var), 'known variable');
my $key = (keys %ENV)[0];
-$var = $ENV{$key};
+ok( tainted($ENV{$key}), 'environment variable');
-print "not " unless tainted($var);
-print "ok 3\n";
-
-print "not " unless tainted($ENV{$key});
-print "ok 4\n";
+$var = $ENV{$key};
+ok( tainted($var), 'copy of environment variable');
}
}
-use vars qw($skip);
-
-BEGIN {
- $|=1;
- require Scalar::Util;
- if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
- print("1..0\n");
- $skip=1;
- }
-
- $DEBUG = 0;
-
- if ($DEBUG && eval { require Devel::Peek } ) {
- Devel::Peek->import('Dump');
- }
- else {
- *Dump = sub {};
- }
+use Scalar::Util ();
+use Test::More (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL)
+ ? (skip_all => 'weaken requires XS version')
+ : (tests => 22);
+
+if (0) {
+ require Devel::Peek;
+ Devel::Peek->import('Dump');
}
-
-eval <<'EOT' unless $skip;
-use Scalar::Util qw(weaken isweak);
-print "1..22\n";
-
-######################### End of black magic.
-
-$cnt = 0;
-
-sub ok {
- ++$cnt;
- if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
- return $_[0];
+else {
+ *Dump = sub {};
}
-$| = 1;
+Scalar::Util->import(qw(weaken isweak));
if(1) {
$y = \$x;
$z = \$x;
}
-print "# START:\n";
+print "# START\n";
Dump($y); Dump($z);
-ok( $y ne "" and $z ne "" );
-weaken($y);
+ok( ref($y) and ref($z));
print "# WEAK:\n";
+weaken($y);
Dump($y); Dump($z);
-ok( $y ne "" and $z ne "" );
-undef($z);
+ok( ref($y) and ref($z));
print "# UNDZ:\n";
+undef($z);
Dump($y); Dump($z);
ok( not (defined($y) and defined($z)) );
-undef($y);
print "# UNDY:\n";
+undef($y);
Dump($y); Dump($z);
ok( not (defined($y) and defined($z)) );
print "# FIN:\n";
Dump($y); Dump($z);
-# exit(0);
-
-# }
-# {
#
# Case 2: one reference, which is weakened
#
-# kill 5,$$;
-
print "# CASE 2:\n";
{
$y = \$x;
}
-ok( $y ne "" );
+ok( ref($y) );
print "# BW: \n";
Dump($y);
weaken($y);
print "# EXITBLOCK\n";
}
-# exit(0);
-
#
# Case 3: a circular structure
#
-# kill 5, $$;
-
$flag = 0;
{
my $y = bless {}, Dest;
print "# 3: $y\n";
weaken($y->{Self});
print "# WKED\n";
- ok( $y ne "" );
+ ok( ref($y) );
print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
" FLAG: ",\$y->{Flag},"\n";
print "# VPRINT\n";
undef($y);
ok( not defined $y);
-ok($z ne "");
+ok( ref($z) );
#
# Case 7: test weaken on a read only ref
#
-if ($] < 5.008003) {
+SKIP: {
# Doesn't work for older perls, see bug [perl #24506]
- print "# Skip next 5 tests on perl $]\n";
- for (1..5) {
- ok(1);
- }
-}
-else {
+ skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
+
$a = eval '\"hello"';
ok(ref($a)) or print "# didn't get a ref from eval\n";
$b = $a;
print "# INCFLAG\n";
${$_[0]{Flag}} ++;
}
-EOT
projects / p5sagit/p5-mst-13.2.git / commitdiff