ext/IPC-SysV/typemap IPC::SysV typemap
ext/List-Util/Changes Util extension
ext/List-Util/lib/List/Util.pm List::Util
+ext/List-Util/lib/List/Util/PP.pm List::Util
+ext/List-Util/lib/List/Util/XS.pm List::Util
ext/List-Util/lib/Scalar/Util.pm Scalar::Util
+ext/List-Util/lib/Scalar/Util/PP.pm Scalar::Util
+ext/List-Util/ListUtil.xs Util extension
ext/List-Util/Makefile.PL Util extension
ext/List-Util/multicall.h Util extension
ext/List-Util/README Util extension
ext/List-Util/t/00version.t Scalar::Util
ext/List-Util/t/blessed.t Scalar::Util
ext/List-Util/t/dualvar.t Scalar::Util
+ext/List-Util/t/expfail.t List::Util
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/minstr.t List::Util
ext/List-Util/t/min.t List::Util
ext/List-Util/t/openhan.t Scalar::Util
+ext/List-Util/t/p_00version.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/sum.t List::Util
ext/List-Util/t/tainted.t Scalar::Util
ext/List-Util/t/weak.t Scalar::Util
-ext/List-Util/Util.xs Util extension
+ext/List-Util/XS.pp List::Util
ext/Math-BigInt-FastCalc/FastCalc.pm Math::BigInt::FastCalc extension
ext/Math-BigInt-FastCalc/FastCalc.xs Math::BigInt::FastCalc extension
ext/Math-BigInt-FastCalc/t/bigintfc.t Math::BigInt::FastCalc extension
+1.21 -- Mon May 18 10:32:14 CDT 2009
+
+ * Change build system for perl-only install not to need to modify blib
+ * When building inside perl, tests for weaken should be always run (Alexandr Ciornii)
+
+1.20 -- Wed May 13 16:42:53 CDT 2009
+
+*** NOTE***
+This distribution now requires perl 5.6 or greater
+
+Bug Fixes
+ * Fixed stack pop issue in POP_MULTICALL
+ * Fixed error reporting in import when XS not compiled
+ * Check first argument to reduce is a CODE reference to avoid segfault
+ * Handle overloaded and tied values
+ * Fix tainted test to run on Win32
+
+Enhancements
+ * Added List::Util::XS so authors can depend on XS version
+ * Removed need for dummy methods in UNIVERSAL for perl-only code
+
+
1.19 -- Sun Dec 10 09:58:03 CST 2006
Bug Fixes
int index;
NV retval;
SV *retsv;
+ int magic;
if(!items) {
XSRETURN_UNDEF;
}
retsv = ST(0);
- retval = slu_sv_value(retsv);
+ magic = SvAMAGIC(retsv);
+ if (!magic) {
+ retval = slu_sv_value(retsv);
+ }
for(index = 1 ; index < items ; index++) {
SV *stacksv = ST(index);
- NV val = slu_sv_value(stacksv);
- if(val < retval ? !ix : ix) {
- retsv = stacksv;
- retval = val;
- }
+ SV *tmpsv;
+ if ((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
+ if (SvTRUE(tmpsv) ? !ix : ix) {
+ retsv = stacksv;
+ magic = SvAMAGIC(retsv);
+ if (!magic) {
+ retval = slu_sv_value(retsv);
+ }
+ }
+ }
+ else {
+ NV val = slu_sv_value(stacksv);
+ if (magic) {
+ retval = slu_sv_value(retsv);
+ magic = 0;
+ }
+ if(val < retval ? !ix : ix) {
+ retsv = stacksv;
+ retval = val;
+ }
+ }
}
ST(0) = retsv;
XSRETURN(1);
-NV
+void
sum(...)
PROTOTYPE: @
CODE:
{
SV *sv;
+ SV *retsv = NULL;
int index;
+ int magic;
+ NV retval = 0;
if(!items) {
XSRETURN_UNDEF;
}
sv = ST(0);
- RETVAL = slu_sv_value(sv);
+ if (SvAMAGIC(sv)) {
+ retsv = sv_newmortal();
+ sv_setsv(retsv, sv);
+ }
+ else {
+ retval = slu_sv_value(sv);
+ }
for(index = 1 ; index < items ; index++) {
sv = ST(index);
- RETVAL += slu_sv_value(sv);
+ if (retsv || SvAMAGIC(sv)) {
+ if (!retsv) {
+ retsv = sv_newmortal();
+ sv_setnv(retsv,retval);
+ }
+ if (!amagic_call(retsv, sv, add_amg, AMGf_assign)) {
+ sv_setnv(retsv, SvNV(retsv) + SvNV(sv));
+ }
+ }
+ else {
+ retval += slu_sv_value(sv);
+ }
+ }
+ if (!retsv) {
+ retsv = sv_newmortal();
+ sv_setnv(retsv,retval);
}
+ ST(0) = retsv;
+ XSRETURN(1);
}
-OUTPUT:
- RETVAL
void
XSRETURN_UNDEF;
}
cv = sv_2cv(block, &stash, &gv, 0);
+ if (cv == Nullcv) {
+ croak("Not a subroutine reference");
+ }
PUSH_MULTICALL(cv);
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SV *sv
PROTOTYPE: $
CODE:
+ SV *tempsv;
+ if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
+ sv = tempsv;
+ }
+ else if (SvMAGICAL(sv)) {
+ SvGETMAGIC(sv);
+ }
#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
if (SvPOK(sv) || SvPOKp(sv)) {
RETVAL = looks_like_number(sv);
+# -*- perl -*-
+BEGIN { require 5.006; } # allow CPAN testers to get the point
+use strict;
+use warnings;
+use Config;
+use File::Spec;
use ExtUtils::MakeMaker;
+my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV;
+
+my $do_xs = $PERL_CORE || can_cc();
+
+for (@ARGV) {
+ /^-pm/ and $do_xs = 0;
+ /^-xs/ and $do_xs = 1;
+}
WriteMakefile(
- VERSION_FROM => "lib/List/Util.pm",
- NAME => "List::Util",
- DEFINE => "-DPERL_EXT",
+ NAME => q[List::Util],
+ ABSTRACT => q[Common Scalar and List utility subroutines],
+ AUTHOR => q[Graham Barr <gbarr@cpan.org>],
+ DEFINE => q[-DPERL_EXT],
+ DISTNAME => q[Scalar-List-Utils],
+ VERSION_FROM => 'lib/List/Util.pm',
+
+ # We go through the ListUtil.xs trickery to foil platforms
+ # that have the feature combination of
+ # (1) static builds
+ # (2) allowing only one object by the same name in the static library
+ # (3) the object name matching being case-blind
+ # This means that we can't have the top-level util.o
+ # and the extension-level Util.o in the same build.
+ # One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
+ XS => {'ListUtil.xs' => 'ListUtil.c'},
+ OBJECT => 'ListUtil$(OBJ_EXT)',
+ ( $PERL_CORE
+ ? ()
+ : (
+ INSTALLDIRS => q[perl],
+ PREREQ_PM => {'Test::More' => 0,},
+ (eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()),
+ ($do_xs ? () : (XS => {}, C => [], OBJECT => '')),
+ ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (
+ META_MERGE => {
+ resources => { ##
+ repository => 'http://github.com/gbarr/Scalar-List-Utils',
+ },
+ }
+ )
+ : ()
+ ),
+ )
+ ),
);
-package MY;
-# We go through the ListUtil.c trickery to foil platforms
-# that have the feature combination of
-# (1) static builds
-# (2) allowing only one object by the same name in the static library
-# (3) the object name matching being case-blind
-# This means that we can't have the top-level util.o
-# and the extension-level Util.o in the same build.
-# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
-
-BEGIN {
- use Config;
- unless (defined $Config{usedl}) {
- eval <<'__EOMM__';
-sub xs_c {
- my($self) = shift;
- return '' unless $self->needs_linking();
-'
-ListUtil.c: Util.xs
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > ListUtil.xsc && $(MV) ListUtil.xsc ListUtil.c
-';
-}
+sub can_cc {
-sub xs_o {
- my($self) = shift;
- return '' unless $self->needs_linking();
-'
+ foreach my $cmd (split(/ /, $Config::Config{cc})) {
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+ }
-Util$(OBJ_EXT): ListUtil.c
- $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) ListUtil.c
- $(MV) ListUtil$(OBJ_EXT) Util$(OBJ_EXT)
-';
+ return;
}
-__EOMM__
- }
+package MY;
+
+sub init_PM {
+ my $self = shift;
+
+ $self->SUPER::init_PM(@_);
+
+ return if $do_xs;
+
+ my $pm = $self->{PM};
+ my $pm_file = File::Spec->catfile(qw(lib List Util XS.pm));
+
+ # When installing pure perl, install XS.pp as XS.pm
+ $self->{PM}{'XS.pp'} = delete $self->{PM}{$pm_file};
}
+
--- /dev/null
+package List::Util::XS;
+use strict;
+use vars qw($VERSION);
+
+$VERSION = undef;
+
+sub VERSION {
+ require Carp;
+ Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled")
+ if defined $_[1];
+ $VERSION;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+List::Util::XS - Indicate if List::Util was compiled with a C compiler
+
+=head1 SYNOPSIS
+
+ use List::Util::XS 1.20;
+
+=head1 DESCRIPTION
+
+B<*** This instalation does not have XS installed ***>
+
+C<List::Util::XS> can be used as a dependency to ensure List::Util was
+installed using a C compiler and that the XS version is installed.
+
+During installation C<$List::Util::XS::VERSION> will be set to
+C<undef> if the XS was not compiled.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 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.
+
+=cut
# List::Util.pm
#
-# Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2009 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.
+#
+# This module is normally only loaded if the XS module is not available
package List::Util;
@ISA = qw(Exporter);
@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION = "1.19";
+$VERSION = "1.21";
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
} unless $TESTING_PERL_ONLY;
-# This code is only compiled if the XS did not load
-# of for perl < 5.6.0
-
-if (!defined &reduce) {
-eval <<'ESQ'
-
-sub reduce (&@) {
- my $code = shift;
- no strict 'refs';
-
- return shift unless @_ > 1;
-
- use vars qw($a $b);
-
- my $caller = caller;
- local(*{$caller."::a"}) = \my $a;
- local(*{$caller."::b"}) = \my $b;
-
- $a = shift;
- foreach (@_) {
- $b = $_;
- $a = &{$code}();
- }
-
- $a;
-}
-
-sub first (&@) {
- my $code = shift;
-
- foreach (@_) {
- return $_ if &{$code}();
- }
-
- undef;
-}
-
-ESQ
-}
-
-# This code is only compiled if the XS did not load
-eval <<'ESQ' if !defined ∑
-
-use vars qw($a $b);
-
-sub sum (@) { reduce { $a + $b } @_ }
-
-sub min (@) { reduce { $a < $b ? $a : $b } @_ }
-
-sub max (@) { reduce { $a > $b ? $a : $b } @_ }
-
-sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
-
-sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
-
-sub shuffle (@) {
- my @a=\(@_);
- my $n;
- my $i=@_;
- map {
- $n = rand($i--);
- (${$a[$n]}, $a[$n] = $a[$i])[0];
- } @_;
+if (!defined &sum) {
+ require List::Util::PP;
+ List::Util::PP->import;
}
-ESQ
-
1;
__END__
$foo = reduce { $a + $b } 1 .. 10 # sum
$foo = reduce { $a . $b } @bar # concat
+If your algorithm requires that C<reduce> produce an identity value, then
+make sure that you always pass that identity value as the first argument to prevent
+C<undef> being returned
+
+ $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value
+
=item shuffle LIST
Returns the elements of LIST in a random order
$foo = reduce { $a + $b } 1..10
+If your algorithm requires that C<sum> produce an identity of 0, then
+make sure that you always pass C<0> as the first argument to prevent
+C<undef> being returned
+
+ $foo = sum 0, @values;
+
=back
=head1 KNOWN BUGS
=head1 COPYRIGHT
-Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2007 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.
--- /dev/null
+# List::Util::PP.pm
+#
+# Copyright (c) 1997-2009 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.
+
+package List::Util::PP;
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT $VERSION $a $b);
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(first min max minstr maxstr reduce sum shuffle);
+$VERSION = "1.21";
+$VERSION = eval $VERSION;
+
+sub reduce (&@) {
+ my $code = shift;
+ unless(ref($code)) {
+ require Carp;
+ Carp::croak("Not a subroutine reference");
+ }
+ no strict 'refs';
+
+ return shift unless @_ > 1;
+
+ use vars qw($a $b);
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = shift;
+ foreach (@_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+sub first (&@) {
+ my $code = shift;
+
+ foreach (@_) {
+ return $_ if &{$code}();
+ }
+
+ undef;
+}
+
+
+sub sum (@) { reduce { $a + $b } @_ }
+
+sub min (@) { reduce { $a < $b ? $a : $b } @_ }
+
+sub max (@) { reduce { $a > $b ? $a : $b } @_ }
+
+sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
+
+sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
+
+sub shuffle (@) {
+ my @a=\(@_);
+ my $n;
+ my $i=@_;
+ map {
+ $n = rand($i--);
+ (${$a[$n]}, $a[$n] = $a[$i])[0];
+ } @_;
+}
+
+1;
--- /dev/null
+package List::Util::XS;
+use strict;
+use vars qw($VERSION);
+use List::Util;
+
+$VERSION = "1.21"; # FIXUP
+$VERSION = eval $VERSION; # FIXUP
+
+sub _VERSION { # FIXUP
+ require Carp;
+ Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled")
+ if defined $_[1];
+ $VERSION;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+List::Util::XS - Indicate if List::Util was compiled with a C compiler
+
+=head1 SYNOPSIS
+
+ use List::Util::XS 1.20;
+
+=head1 DESCRIPTION
+
+C<List::Util::XS> can be used as a dependency to ensure List::Util was
+installed using a C compiler and that the XS version is installed.
+
+During installation C<$List::Util::XS::VERSION> will be set to
+C<undef> if the XS was not compiled.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 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.
+
+=cut
# Scalar::Util.pm
#
-# Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1997-2007 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.
package Scalar::Util;
use strict;
-use vars qw(@ISA @EXPORT_OK $VERSION);
+use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL);
require Exporter;
require List::Util; # List::Util loads the XS
@ISA = qw(Exporter);
@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
-$VERSION = "1.19";
+$VERSION = "1.21";
$VERSION = eval $VERSION;
+unless (defined &dualvar) {
+ # Load Pure Perl version if XS not loaded
+ require Scalar::Util::PP;
+ Scalar::Util::PP->import;
+ push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
+}
+
sub export_fail {
+ if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded
+ my $pat = join("|", @EXPORT_FAIL);
+ if (my ($err) = grep { /^($pat)$/ } @_ ) {
+ require Carp;
+ Carp::croak("$err is only available with the XS version of Scalar::Util");
+ }
+ }
+
if (grep { /^(weaken|isweak)$/ } @_ ) {
require Carp;
Carp::croak("Weak references are not implemented in the version of perl");
}
+
if (grep { /^(isvstring)$/ } @_ ) {
require Carp;
Carp::croak("Vstrings are not implemented in the version of perl");
}
- if (grep { /^(dualvar|set_prototype)$/ } @_ ) {
- require Carp;
- Carp::croak("$1 is only avaliable with the XS version");
- }
@_;
}
? $fh : undef;
}
-eval <<'ESQ' unless defined &dualvar;
-
-use vars qw(@EXPORT_FAIL);
-push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
-
-# The code beyond here is only used if the XS is not installed
-
-# Hope nobody defines a sub by this name
-sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
-
-sub blessed ($) {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- length(ref($_[0]))
- ? eval { $_[0]->a_sub_not_likely_to_be_here }
- : undef
-}
-
-sub refaddr($) {
- my $pkg = ref($_[0]) or return undef;
- if (blessed($_[0])) {
- bless $_[0], 'Scalar::Util::Fake';
- }
- else {
- $pkg = undef;
- }
- "$_[0]" =~ /0x(\w+)/;
- my $i = do { local $^W; hex $1 };
- bless $_[0], $pkg if defined $pkg;
- $i;
-}
-
-sub reftype ($) {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- my $r = shift;
- my $t;
-
- length($t = ref($r)) or return undef;
-
- # This eval will fail if the reference is not blessed
- eval { $r->a_sub_not_likely_to_be_here; 1 }
- ? do {
- $t = eval {
- # we have a GLOB or an IO. Stringify a GLOB gives it's name
- my $q = *$r;
- $q =~ /^\*/ ? "GLOB" : "IO";
- }
- or do {
- # OK, if we don't have a GLOB what parts of
- # a glob will it populate.
- # NOTE: A glob always has a SCALAR
- local *glob = $r;
- defined *glob{ARRAY} && "ARRAY"
- or defined *glob{HASH} && "HASH"
- or defined *glob{CODE} && "CODE"
- or length(ref(${$r})) ? "REF" : "SCALAR";
- }
- }
- : $t
-}
-
-sub tainted {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- local $^W = 0;
- eval { kill 0 * $_[0] };
- $@ =~ /^Insecure/;
-}
-
-sub readonly {
- return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
-
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- my $tmp = $_[0];
-
- !eval { $_[0] = $tmp; 1 };
-}
-
-sub looks_like_number {
- local $_ = shift;
-
- # checks from perlfaq4
- return 0 if !defined($_) or ref($_);
- return 1 if (/^[+-]?\d+$/); # is a +/- integer
- return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
- return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
-
- 0;
-}
-
-ESQ
-
1;
__END__
use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
weaken isvstring looks_like_number set_prototype);
+ # and other useful utils appearing below
=head1 DESCRIPTION
B<NOTE>: Copying a weak reference creates a normal, strong, reference.
$copy = $ref;
- $weak = isweak($ref); # false
+ $weak = isweak($copy); # false
=item looks_like_number EXPR
=back
+=head1 DIAGNOSTICS
+
+Module use may give one of the following errors during import.
+
+=over
+
+=item Weak references are not implemented in the version of perl
+
+The version of perl that you are using does not implement weak references, to use
+C<isweak> or C<weaken> you will need to use a newer release of perl.
+
+=item Vstrings are not implemented in the version of perl
+
+The version of perl that you are using does not implement Vstrings, to use
+C<isvstring> you will need to use a newer release of perl.
+
+=item C<NAME> is only available with the XS version of Scalar::Util
+
+C<Scalar::Util> contains both perl and C implementations of many of its functions
+so that those without access to a C compiler may still use it. However some of the functions
+are only available when a C compiler was available to compile the XS version of the extension.
+
+At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
+
+=back
+
=head1 KNOWN BUGS
There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
=head1 COPYRIGHT
-Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
+Copyright (c) 1997-2007 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.
--- /dev/null
+# Scalar::Util::PP.pm
+#
+# Copyright (c) 1997-2009 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.
+#
+# This module is normally only loaded if the XS module is not available
+
+package Scalar::Util::PP;
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT $VERSION $recurse);
+require Exporter;
+use B qw(svref_2object);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number);
+$VERSION = "1.21";
+$VERSION = eval $VERSION;
+
+sub blessed ($) {
+ return undef unless length(ref($_[0]));
+ my $b = svref_2object($_[0]);
+ return undef unless $b->isa('B::PVMG');
+ my $s = $b->SvSTASH;
+ return $s->isa('B::HV') ? $s->NAME : undef;
+}
+
+sub refaddr($) {
+ return undef unless length(ref($_[0]));
+
+ my $addr;
+ if(defined(my $pkg = blessed($_[0]))) {
+ $addr .= bless $_[0], 'Scalar::Util::Fake';
+ bless $_[0], $pkg;
+ }
+ else {
+ $addr .= $_[0]
+ }
+
+ $addr =~ /0x(\w+)/;
+ local $^W;
+ hex($1);
+}
+
+{
+ my %tmap = qw(
+ B::HV HASH
+ B::AV ARRAY
+ B::CV CODE
+ B::IO IO
+ B::NULL SCALAR
+ B::NV SCALAR
+ B::PV SCALAR
+ B::GV GLOB
+ B::RV REF
+ B::REGEXP REGEXP
+ );
+
+ sub reftype ($) {
+ my $r = shift;
+
+ return undef unless length(ref($r));
+
+ my $t = ref(svref_2object($r));
+
+ return
+ exists $tmap{$t} ? $tmap{$t}
+ : length(ref($$r)) ? 'REF'
+ : 'SCALAR';
+ }
+}
+
+sub tainted {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ no warnings;
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+sub readonly {
+ return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
+
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $tmp = $_[0];
+
+ !eval { $_[0] = $tmp; 1 };
+}
+
+sub looks_like_number {
+ local $_ = shift;
+
+ # checks from perlfaq4
+ return 0 if !defined($_);
+ if (ref($_)) {
+ require overload;
+ return overload::Overloaded($_) ? defined(0 + $_) : 0;
+ }
+ return 1 if (/^[+-]?\d+$/); # is a +/- integer
+ return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
+ return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
+
+ 0;
+}
+
+
+1;
use Scalar::Util ();
use List::Util ();
-use Test::More tests => 1;
+use List::Util::XS ();
+use Test::More tests => 2;
is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch");
-
+my $has_xs = eval { Scalar::Util->import('dualvar'); 1 };
+my $xs_version = $has_xs ? $List::Util::VERSION : undef;
+is( $List::Util::XS::VERSION, $xs_version, "XS VERSION");
}
}
-use Test::More tests => 8;
+use Test::More tests => 11;
use Scalar::Util qw(blessed);
use vars qw($t $x);
$x = bless {}, "DEF";
is(blessed($x), "DEF", 'blessed HASH-ref');
+
+$x = bless {}, "0";
+cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
+
+{
+ my $depth;
+ {
+ no warnings 'redefine';
+ *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) };
+ }
+ $x = bless {}, "DEF";
+ is(blessed($x), "DEF", 'recursion of UNIVERSAL::can');
+}
+
+{
+ package Broken;
+ sub isa { die };
+ sub can { die };
+
+ my $obj = bless [], __PACKAGE__;
+ ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" );
+}
+
ok( $var == $numstr, 'NV');
-$var = dualvar(1<<31, "");
-ok( $var == (1<<31), 'UV 1');
-ok( $var > 0, 'UV 2');
+SKIP: {
+ skip("dualvar with UV value known to fail with $]",2) if $] < 5.006_001;
+ $var = dualvar(1<<31, "");
+ ok( $var == (1<<31), 'UV 1');
+ ok( $var > 0, 'UV 2');
+}
tie my $tied, 'Tied';
$var = dualvar($tied, "ok");
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ keys %Config; # Silence warning
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+}
+
+use Test::More tests => 3;
+use strict;
+
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
+require Scalar::Util;
+
+for my $func (qw(dualvar set_prototype weaken)) {
+ eval { Scalar::Util->import($func); };
+ like(
+ $@,
+ qr/$func is only available with the XS/,
+ "no pure perl $func: error raised",
+ );
+}
}
use strict;
-use Test::More tests => 16;
+use Test::More tests => 18;
use Scalar::Util qw(looks_like_number);
foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) {
use Math::BigInt;
my $bi = Math::BigInt->new('1234567890');
-is(!!looks_like_number($bi), '', 'Math::BigInt');
+is(!!looks_like_number($bi), 1, 'Math::BigInt');
is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt');
+{ package Foo;
+sub TIEHASH { bless {} }
+sub FETCH { $_[1] }
+}
+my %foo;
+tie %foo, 'Foo';
+is(!!looks_like_number($foo{'abc'}), '', 'Tied');
+is(!!looks_like_number($foo{'123'}), 1, 'Tied');
+
# We should copy some of perl core tests like t/base/num.t here
}
use strict;
-use Test::More tests => 5;
+use Test::More tests => 8;
use List::Util qw(max);
my $v;
my @b = sort { $a <=> $b } @a;
$v = max(@a);
is($v, $b[-1], '20-arg random order');
+
+my $one = Foo->new(1);
+my $two = Foo->new(2);
+my $thr = Foo->new(3);
+
+$v = max($one,$two,$thr);
+is($v, 3, 'overload');
+
+$v = max($thr,$two,$one);
+is($v, 3, 'overload');
+
+{ package Foo;
+
+use overload
+ '""' => sub { ${$_[0]} },
+ '+0' => sub { ${$_[0]} },
+ fallback => 1;
+ sub new {
+ my $class = shift;
+ my $value = shift;
+ bless \$value, $class;
+ }
+}
+
+SKIP: {
+ eval { require bignum; } or skip("Need bignum for testing overloading",1);
+
+ my $v1 = 2**65;
+ my $v2 = $v1 - 1;
+ my $v3 = $v2 - 1;
+ $v = max($v1,$v2,$v1,$v3,$v1);
+ is($v, $v1, 'bigint');
+}
}
use strict;
-use Test::More tests => 5;
+use Test::More tests => 8;
use List::Util qw(min);
my $v;
my @b = sort { $a <=> $b } @a;
$v = min(@a);
is($v, $b[0], '20-arg random order');
+
+my $one = Foo->new(1);
+my $two = Foo->new(2);
+my $thr = Foo->new(3);
+
+$v = min($one,$two,$thr);
+is($v, 1, 'overload');
+
+$v = min($thr,$two,$one);
+is($v, 1, 'overload');
+
+{ package Foo;
+
+use overload
+ '""' => sub { ${$_[0]} },
+ '+0' => sub { ${$_[0]} },
+ fallback => 1;
+ sub new {
+ my $class = shift;
+ my $value = shift;
+ bless \$value, $class;
+ }
+}
+
+SKIP: {
+ eval { require bignum; } or skip("Need bignum for testing overloading",1);
+
+ my $v1 = 2**65;
+ my $v2 = $v1 - 1;
+ my $v3 = $v2 - 1;
+ $v = min($v1,$v2,$v1,$v3,$v1);
+ is($v, $v3, 'bigint');
+}
}
use strict;
-use vars qw(*CLOSED);
-use Test::More tests => 4;
+
+use Test::More tests => 14;
use Scalar::Util qw(openhandle);
ok(defined &openhandle, 'defined');
-my $fh = \*STDERR;
-is(openhandle($fh), $fh, 'STDERR');
+{
+ my $fh = \*STDERR;
+ is(openhandle($fh), $fh, 'STDERR');
+
+ is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
+}
+
+{
+ use vars qw(*CLOSED);
+ is(openhandle(*CLOSED), undef, 'closed');
+}
+
+SKIP: {
+ skip "3-arg open only on 5.6 or later", 1 if $]<5.006;
+
+ open my $fh, "<", $0;
+ skip "could not open $0 for reading: $!", 1 unless $fh;
+ is(openhandle($fh), $fh, "works with indirect filehandles");
+}
+
+SKIP: {
+ skip "in-memory files only on 5.8 or later", 1 if $]<5.008;
+
+ open my $fh, "<", \"in-memory file";
+ skip "could not open in-memory file: $!", 1 unless $fh;
+ is(openhandle($fh), $fh, "works with in-memory files");
+}
-is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
+ok(openhandle(\*DATA), "works for \*DATA");
+ok(openhandle(*DATA), "works for *DATA");
+ok(openhandle(*DATA{IO}), "works for *DATA{IO}");
-is(openhandle(*CLOSED), undef, 'closed');
+{
+ require IO::Handle;
+ my $fh = IO::Handle->new_from_fd(fileno(*STDERR), 'w');
+ skip "new_from_fd(fileno(*STDERR)) failed", 1 unless $fh;
+ ok(openhandle($fh), "works for IO::Handle objects");
+
+ ok(!openhandle(IO::Handle->new), "unopened IO::Handle");
+}
+
+{
+ require IO::File;
+ my $fh = IO::File->new;
+ $fh->open("< $0")
+ or skip "could not open $0: $!", 1;
+ ok(openhandle($fh), "works for IO::File objects");
+
+ ok(!openhandle(IO::File->new), "unopened IO::File" );
+}
+
+SKIP: {
+ skip( "Tied handles only on 5.8 or later", 1) if $]<5.008;
+
+ use vars qw(*H);
+
+ package My::Tie;
+ require Tie::Handle;
+ @My::Tie::ISA = qw(Tie::Handle);
+ sub TIEHANDLE { bless {} }
+
+ package main;
+ tie *H, 'My::Tie';
+ ok(openhandle(*H), "tied handles are always ok");
+}
+__DATA__
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ keys %Config; # Silence warning
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+}
+
+use Test::More tests => 2;
+
+# force perl-only version to be tested
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
+
+require Scalar::Util;
+require List::Util;
+
+is( $Scalar::Util::PP::VERSION, $List::Util::VERSION, "VERSION mismatch");
+is( $List::Util::PP::VERSION, $List::Util::VERSION, "VERSION mismatch");
+
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
-my $filename = File::Spec->catfile(".", $f);
+my $filename = $^O eq 'MSWin32'
+ ? File::Spec->rel2abs(File::Spec->catfile(".", $f))
+ : File::Spec->catfile(".", $f);
do $filename; die $@ if $@;
use List::Util qw(reduce min);
use Test::More;
-plan tests => ($::PERL_ONLY ? 21 : 23);
+plan tests => ($::PERL_ONLY ? 23 : 25);
my $v = reduce {};
is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
}
+{
+ my $ok = 'failed';
+ local $SIG{__DIE__} = sub { $ok = $_[0] =~ /Not a (subroutine|CODE) reference/ ? '' : $_[0] };
+ eval { &reduce('foo',1,2) };
+ is($ok, '', 'Not a subroutine reference');
+ $ok = 'failed';
+ eval { &reduce({},1,2) };
+ is($ok, '', 'Not a subroutine reference');
+}
+
# The remainder of the tests are only relevant for the XS
# implementation. The Perl-only implementation behaves differently
# (and more flexibly) in a way that we can't emulate from XS.
}
-use Test::More tests => 29;
+use Test::More tests => 32;
use Scalar::Util qw(refaddr);
use vars qw($t $y $x *F $v $r);
ok(refaddr($x{$y}));
ok(refaddr($x{$b}));
}
+{
+ my $z = bless {}, '0';
+ ok(refaddr($z));
+ @{"0::ISA"} = qw(FooBar);
+ my $a = {};
+ my $r = refaddr($a);
+ $z = bless $a, '0';
+ ok(refaddr($z) > 10);
+ is(refaddr($z),$r,"foo");
+}
package FooBar;
use overload '0+' => sub { 10 },
- '+' => sub { 10 + $_[1] };
+ '+' => sub { 10 + $_[1] },
+ '"' => sub { "10" };
package MyTie;
}
}
-use Test::More tests => 23;
+use Test::More tests => 29;
use Scalar::Util qw(reftype);
use vars qw($t $y $x *F);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
+my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP';
@test = (
[ undef, 1, 'number' ],
[ GLOB => \*F, 'tied GLOB ref' ],
[ GLOB => gensym, 'GLOB ref' ],
[ CODE => sub {}, 'CODE ref' ],
-# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
+ [ IO => *STDIN{IO},'IO ref' ],
+ [ $RE => qr/x/, 'REGEEXP' ],
);
foreach $test (@test) {
exit 0;
}
}
+ if ($] eq "5.008009" or $] eq "5.010000" or $] le "5.006002") {
+ print "1..0 # Skip: known to fail on $]\n";
+ exit 0;
+ }
}
use List::Util qw(reduce);
}
}
-use Test::More tests => 6;
+use Test::More tests => 8;
use List::Util qw(sum);
$v = sum(-3.5,3);
is( $v, -0.5, 'real numbers');
+my $one = Foo->new(1);
+my $two = Foo->new(2);
+my $thr = Foo->new(3);
+
+$v = sum($one,$two,$thr);
+is($v, 6, 'overload');
+
+
+{ package Foo;
+
+use overload
+ '""' => sub { ${$_[0]} },
+ '+0' => sub { ${$_[0]} },
+ fallback => 1;
+ sub new {
+ my $class = shift;
+ my $value = shift;
+ bless \$value, $class;
+ }
+}
+
+SKIP: {
+ eval { require bignum; } or skip("Need bignum for testing overloading",1);
+
+ my $v1 = 2**65;
+ my $v2 = 2**65;
+ my $v3 = $v1 + $v2;
+ $v = sum($v1,$v2);
+ is($v, $v3, 'bignum');
+}
#!./perl
+use strict;
+use Config;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
- require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
}
use Scalar::Util ();
-use Test::More (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL)
+use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE})
? (skip_all => 'weaken requires XS version')
: (tests => 22);
# Case 3: a circular structure
#
-$flag = 0;
+my $flag = 0;
{
- my $y = bless {}, Dest;
+ my $y = bless {}, 'Dest';
Dump($y);
print "# 1: $y\n";
$y->{Self} = $y;
$flag = 0;
{
- my $y = bless {}, Dest;
- my $x = bless {}, Dest;
+ my $y = bless {}, 'Dest';
+ my $x = bless {}, 'Dest';
$x->{Ref} = $y;
$y->{Ref} = $x;
$x->{Flag} = \$flag;
# Case 5: deleting a weakref before the other one
#
+my ($y,$z);
{
my $x = "foo";
$y = \$x;
$b = \$a;
ok(!isweak($b));
-$x = {};
+my $x = {};
weaken($x->{Y} = \$a);
ok(isweak($x->{Y}));
ok(!isweak($x->{Z}));
projects / p5sagit/p5-mst-13.2.git / commitdiff