Now we have blessed, reftype, tainted, first, reduce, ...
p4raw-id: //depot/perl@9702
+ext/List/Util/ChangeLog Util extension
+ext/List/Util/Makefile.PL Util extension
+ext/List/Util/README Util extension
+ext/List/Util/Util.xs Util extension
+ext/List/Util/lib/List/Util.pm List::Util
+ext/List/Util/lib/Scalar/Util.pm Scalar::Util
+t/lib/u-blessed.t Scalar::Util
+t/lib/u-dualvar.t Scalar::Util
+t/lib/u-first.t List::Util
+t/lib/u-max.t List::Util
+t/lib/u-maxstr.t List::Util
+t/lib/u-min.t List::Util
+t/lib/u-minstr.t List::Util
+t/lib/u-readonly.t Scalar::Util
+t/lib/u-reduce.t List::Util
+t/lib/u-reftype.t Scalar::Util
+t/lib/u-sum.t List::Util
+t/lib/u-tainted.t Scalar::Util
+t/lib/u-weak.t Scalar::Util
AUTHORS Contact info for contributors
Artistic The "Artistic License"
Changes Differences from previous version
--- /dev/null
+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
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ VERSION_FROM => "lib/List/Util.pm",
+ NAME => "List::Util",
+);
+
--- /dev/null
+This distribution is a replacement for the builtin distribution.
+
+This package contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would not
+really be high enough to warrant the use of a keyword, and the size so
+small such that being individual extensions would be wasteful.
+
+After unpacking the distribution, to install this module type
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+This distribution provides
+
+ min
+ max
+ minstr
+ maxstr
+ sum
+ reduce
+ reftype
+ blessed
+ weaken (5.005_57 and later only)
+ isweak (5.005_57 and later only)
+ dualvar
+
+Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+/* Copyright (c) 1997-2000 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.
+ */
+
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#include <patchlevel.h>
+
+#if PATCHLEVEL < 5
+# ifndef gv_stashpvn
+# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
+# endif
+# ifndef SvTAINTED
+
+static bool
+sv_tainted(SV *sv)
+{
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
+ return TRUE;
+ }
+ return FALSE;
+}
+
+# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
+# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+# endif
+# define PL_defgv defgv
+# define PL_op op
+# define PL_curpad curpad
+# define CALLRUNOPS runops
+# define PL_curpm curpm
+# define PL_sv_undef sv_undef
+# define PERL_CONTEXT struct context
+#endif
+#if (PATCHLEVEL < 5) || (PATCHLEVEL == 5 && SUBVERSION <50)
+# ifndef PL_tainting
+# define PL_tainting tainting
+# endif
+# ifndef PL_stack_base
+# define PL_stack_base stack_base
+# endif
+# ifndef PL_stack_sp
+# define PL_stack_sp stack_sp
+# endif
+# ifndef PL_ppaddr
+# define PL_ppaddr ppaddr
+# endif
+#endif
+
+MODULE=List::Util PACKAGE=List::Util
+
+void
+min(...)
+PROTOTYPE: @
+ALIAS:
+ min = 0
+ max = 1
+CODE:
+{
+ int index;
+ NV retval;
+ SV *retsv;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ retsv = ST(0);
+ retval = SvNV(retsv);
+ for(index = 1 ; index < items ; index++) {
+ SV *stacksv = ST(index);
+ NV val = SvNV(stacksv);
+ if(val < retval ? !ix : ix) {
+ retsv = stacksv;
+ retval = val;
+ }
+ }
+ ST(0) = retsv;
+ XSRETURN(1);
+}
+
+
+
+NV
+sum(...)
+PROTOTYPE: @
+CODE:
+{
+ int index;
+ NV ret;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = SvNV(ST(0));
+ for(index = 1 ; index < items ; index++) {
+ RETVAL += SvNV(ST(index));
+ }
+}
+OUTPUT:
+ RETVAL
+
+
+void
+minstr(...)
+PROTOTYPE: @
+ALIAS:
+ minstr = 2
+ maxstr = 0
+CODE:
+{
+ SV *left;
+ int index;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ /*
+ sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
+ so we set ix to the value we are looking for
+ xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
+ */
+ ix -= 1;
+ left = ST(0);
+#ifdef OPpLOCALE
+ if(MAXARG & OPpLOCALE) {
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp_locale(left, right) == ix)
+ left = right;
+ }
+ }
+ else {
+#endif
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp(left, right) == ix)
+ left = right;
+ }
+#ifdef OPpLOCALE
+ }
+#endif
+ ST(0) = left;
+ XSRETURN(1);
+}
+
+
+
+void
+reduce(block,...)
+ SV * block
+PROTOTYPE: &@
+CODE:
+{
+ SV *ret;
+ int index;
+ I32 markix;
+ GV *agv,*bgv,*gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ agv = gv_fetchpv("a", TRUE, SVt_PV);
+ bgv = gv_fetchpv("b", TRUE, SVt_PV);
+ SAVESPTR(GvSV(agv));
+ SAVESPTR(GvSV(bgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ ret = ST(1);
+ markix = sp - PL_stack_base;
+ for(index = 2 ; index < items ; index++) {
+ GvSV(agv) = ret;
+ GvSV(bgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS();
+ ret = *PL_stack_sp;
+ }
+ ST(0) = ret;
+ XSRETURN(1);
+}
+
+void
+first(block,...)
+ SV * block
+PROTOTYPE: &@
+CODE:
+{
+ SV *ret;
+ int index;
+ I32 markix;
+ GV *gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ SAVESPTR(GvSV(PL_defgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ markix = sp - PL_stack_base;
+ for(index = 1 ; index < items ; index++) {
+ GvSV(PL_defgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS();
+ if (SvTRUE(*PL_stack_sp)) {
+ ST(0) = ST(index);
+ XSRETURN(1);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+MODULE=List::Util PACKAGE=Scalar::Util
+
+void
+dualvar(num,str)
+ SV * num
+ SV * str
+PROTOTYPE: $$
+CODE:
+{
+ STRLEN len;
+ char *ptr = SvPV(str,len);
+ ST(0) = sv_newmortal();
+ SvUPGRADE(ST(0),SVt_PVNV);
+ sv_setpvn(ST(0),ptr,len);
+ if(SvNOKp(num) || !SvIOKp(num)) {
+ SvNVX(ST(0)) = SvNV(num);
+ SvNOK_on(ST(0));
+ }
+ else {
+ SvIVX(ST(0)) = SvIV(num);
+ SvIOK_on(ST(0));
+ }
+ if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
+ SvTAINTED_on(ST(0));
+ XSRETURN(1);
+}
+
+char *
+blessed(sv)
+ SV * sv
+PROTOTYPE: $
+CODE:
+{
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!sv_isobject(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),TRUE);
+}
+OUTPUT:
+ RETVAL
+
+char *
+reftype(sv)
+ SV * sv
+PROTOTYPE: $
+CODE:
+{
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!SvROK(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),FALSE);
+}
+OUTPUT:
+ RETVAL
+
+void
+weaken(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+
+SV *
+isweak(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvWEAKREF
+ ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
+ XSRETURN(1);
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+
+int
+readonly(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+ RETVAL = SvREADONLY(sv);
+OUTPUT:
+ RETVAL
+
+int
+tainted(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+ RETVAL = SvTAINTED(sv);
+OUTPUT:
+ RETVAL
+
+BOOT:
+{
+#ifndef SvWEAKREF
+ HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
+ GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+ AV *varav;
+ if (SvTYPE(vargv) != SVt_PVGV)
+ gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
+ varav = GvAVn(vargv);
+ av_push(varav, newSVpv("weaken",6));
+ av_push(varav, newSVpv("isweak",6));
+#endif
+}
--- /dev/null
+# List::Util.pm
+#
+# Copyright (c) 1997-2000 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;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(first min max minstr maxstr reduce sum);
+$VERSION = $VERSION = "1.02";
+
+eval {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap List::Util $VERSION;
+ 1
+};
+
+eval <<'ESQ' unless defined &reduce;
+
+# This code is only compiled if the XS did not load
+
+use vars qw($a $b);
+
+sub reduce (&@) {
+ my $code = shift;
+
+ return shift unless @_ > 1;
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = shift;
+ foreach (@_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+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 first (&@) {
+ my $code = shift;
+
+ foreach (@_) {
+ return $_ if &{$code}();
+ }
+
+ undef;
+}
+ESQ
+
+1;
+
+__END__
+
+=head1 NAME
+
+List::Util - A selection of general-utility list subroutines
+
+=head1 SYNOPSIS
+
+ use List::Util qw(first sum min max minstr maxstr reduce);
+
+=head1 DESCRIPTION
+
+C<List::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<List::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item first BLOCK LIST
+
+Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
+of LIST in turn. C<first> returns the first element where the result from
+BLOCK is a true value. If BLOCK never returns true or LIST was empty then
+C<undef> is returned.
+
+ $foo = first { defined($_) } @list # first defined value in @list
+ $foo = first { $_ > $value } @list # first value in @list which
+ # is greater than $value
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
+
+for example wanted() could be defined() which would return the first
+defined value in @list
+
+=item max LIST
+
+Returns the entry in the list with the highest numerical value. If the
+list is empty then C<undef> is returned.
+
+ $foo = max 1..10 # 10
+ $foo = max 3,9,12 # 12
+ $foo = max @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a > $b ? $a : $b } 1..10
+
+=item maxstr LIST
+
+Similar to C<max>, but treats all the entries in the list as strings
+and returns the highest string as defined by the C<gt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'Z'
+ $foo = maxstr "hello","world" # "world"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
+
+=item min LIST
+
+Similar to C<max> but returns the entry in the list with the lowest
+numerical value. If the list is empty then C<undef> is returned.
+
+ $foo = min 1..10 # 1
+ $foo = min 3,9,12 # 3
+ $foo = min @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10
+
+=item minstr LIST
+
+Similar to C<min>, but treats all the entries in the list as strings
+and returns the lowest string as defined by the C<lt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'A'
+ $foo = maxstr "hello","world" # "hello"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
+
+=item reduce BLOCK LIST
+
+Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b>
+each time. The first call will be with C<$a> and C<$b> set to the first
+two elements of the list, subsequent calls will be done by
+setting C<$a> to the result of the previous call and C<$b> to the next
+element in the list.
+
+Returns the result of the last call to BLOCK. If LIST is empty then
+C<undef> is returned. If LIST only contains one element then that
+element is returned and BLOCK is not executed.
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10 # min
+ $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
+ $foo = reduce { $a + $b } 1 .. 10 # sum
+ $foo = reduce { $a . $b } @bar # concat
+
+=item sum LIST
+
+Returns the sum of all the elements in LIST.
+
+ $foo = sum 1..10 # 55
+ $foo = sum 3,9,12 # 24
+ $foo = sum @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a + $b } 1..10
+
+=back
+
+=head1 SUGGESTED ADDITIONS
+
+The following are additions that have been requested, but I have been reluctant
+to add due to them being very simple to implement in perl
+
+ # One argument is true
+
+ sub any { $_ && return 1 for @_; 0 }
+
+ # All arguments are true
+
+ sub all { $_ || return 0 for @_; 1 }
+
+ # All arguments are false
+
+ sub none { $_ && return 0 for @_; 1 }
+
+ # One argument is false
+
+ sub notall { $_ || return 1 for @_; 0 }
+
+ # How many elements are true
+
+ sub true { scalar grep { $_ } @_ }
+
+ # How many elements are false
+
+ sub false { scalar grep { !$_ } @_ }
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000 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
--- /dev/null
+# Scalar::Util.pm
+#
+# Copyright (c) 1997-2000 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;
+
+require Exporter;
+require List::Util; # List::Util loads the XS
+
+$VERSION = $VERSION = $List::Util::VERSION;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly);
+
+sub export_fail {
+ if (grep { /^(weaken|isweak)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Weak references are not implemented in the version of perl");
+ }
+ if (grep { /^dualvar$/ } @_ ) {
+ require Carp;
+ Carp::croak("dualvar is only avaliable with the XS version");
+ }
+
+ @_;
+}
+
+eval <<'ESQ' unless defined &dualvar;
+
+push @EXPORT_FAIL, qw(weaken isweak dualvar);
+
+# 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 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 };
+}
+
+ESQ
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scalar::Util - A selection of general-utility scalar subroutines
+
+=head1 SYNOPSIS
+
+ use Scalar::Util qw(blessed dualvar reftype weaken isweak);
+
+=head1 DESCRIPTION
+
+C<Scalar::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<Scalar::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item blessed EXPR
+
+If EXPR evaluates to a blessed reference the name of the package
+that it is blessed into is returned. Otherwise C<undef> is returned.
+
+=item dualvar NUM, STRING
+
+Returns a scalar that has the value NUM in a numeric context and the
+value STRING in a string context.
+
+ $foo = dualvar 10, "Hello";
+ $num = $foo + 2; # 12
+ $str = $foo . " world"; # Hello world
+
+=item isweak EXPR
+
+If EXPR is a scalar which is a weak reference the result is true.
+
+=item reftype EXPR
+
+If EXPR evaluates to a reference the type of the variable referenced
+is returned. Otherwise C<undef> is returned.
+
+=item weaken REF
+
+REF will be turned into a weak reference. This means that it will not
+hold a reference count on the object it references. Also when the reference
+count on that object reaches zero, REF will be set to undef.
+
+This is useful for keeping copies of references , but you don't want to
+prevent the object being DESTROY-ed at it's usual time.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000 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.
+
+except weaken and isweak which are
+
+Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=head1 BLATANT PLUG
+
+The weaken and isweak subroutines in this module and the patch to the core Perl
+were written in connection with the APress book `Tuomas J. Lukka's Definitive
+Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
+things would have to be done in cumbersome ways.
+
+=cut
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(blessed);
+use vars qw($t $y $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";
+
+$x = bless [], "ABC";
+
+print "not " unless blessed($x);
+print "ok 6\n";
+
+print "not " unless blessed($x) eq 'ABC';
+print "ok 7\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ require Scalar::Util;
+
+ if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
+ print "1..0\n";
+ exit;
+ }
+}
+
+use Scalar::Util qw(dualvar);
+
+print "1..6\n";
+
+$var = dualvar 2.2,"string";
+
+print "not " unless $var == 2.2;
+print "ok 1\n";
+
+print "not " unless $var eq "string";
+print "ok 2\n";
+
+$var2 = $var;
+
+$var++;
+
+print "not " unless $var == 3.2;
+print "ok 3\n";
+
+print "not " unless $var ne "string";
+print "ok 4\n";
+
+print "not " unless $var2 == 2.2;
+print "ok 5\n";
+
+print "not " unless $var2 eq "string";
+print "ok 6\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(first);
+
+print "1..4\n";
+
+print "not " unless defined &first;
+print "ok 1\n";
+
+print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6;
+print "ok 2\n";
+
+print "not " if defined(first { 0 } 1,2,3,4);
+print "ok 3\n";
+
+print "not " if defined(first { 0 });
+print "ok 4\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(max);
+
+print "1..5\n";
+
+print "not " unless defined &max;
+print "ok 1\n";
+
+print "not " unless max(1) == 1;
+print "ok 2\n";
+
+print "not " unless max(1,2) == 2;
+print "ok 3\n";
+
+print "not " unless max(2,1) == 2;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless max(@a) == $b[-1];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(maxstr);
+
+print "1..5\n";
+
+print "not " unless defined &maxstr;
+print "ok 1\n";
+
+print "not " unless maxstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless maxstr('a','b') eq 'b';
+print "ok 3\n";
+
+print "not " unless maxstr('B','A') eq 'B';
+print "ok 4\n";
+
+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";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(min);
+
+print "1..5\n";
+
+print "not " unless defined &min;
+print "ok 1\n";
+
+print "not " unless min(9) == 9;
+print "ok 2\n";
+
+print "not " unless min(1,2) == 1;
+print "ok 3\n";
+
+print "not " unless min(2,1) == 1;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless min(@a) == $b[0];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(minstr);
+
+print "1..5\n";
+
+print "not " unless defined &minstr;
+print "ok 1\n";
+
+print "not " unless minstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless minstr('a','b') eq 'a';
+print "ok 3\n";
+
+print "not " unless minstr('B','A') eq 'A';
+print "ok 4\n";
+
+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";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(readonly);
+
+print "1..9\n";
+
+print "not " unless readonly(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if readonly($var);
+print "ok 2\n";
+
+print "not " unless $var == 2;
+print "ok 3\n";
+
+print "not " unless readonly("fred");
+print "ok 4\n";
+
+$var = "fred";
+
+print "not " if readonly($var);
+print "ok 5\n";
+
+print "not " unless $var eq "fred";
+print "ok 6\n";
+
+$var = \2;
+
+print "not " if readonly($var);
+print "ok 7\n";
+
+print "not " unless readonly($$var);
+print "ok 8\n";
+
+print "not " if readonly(*STDOUT);
+print "ok 9\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(reduce min);
+
+print "1..5\n";
+
+print "not " if defined reduce {};
+print "ok 1\n";
+
+print "not " unless 9 == reduce { $a / $b } 756,3,7,4;
+print "ok 2\n";
+
+print "not " unless 9 == reduce { $a / $b } 9;
+print "ok 3\n";
+
+@a = map { rand } 0 .. 20;
+print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a;
+print "ok 4\n";
+
+@a = map { pack("C", int(rand(256))) } 0 .. 20;
+print "not " unless join("",@a) eq reduce { $a . $b } @a;
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(reftype);
+use vars qw($t $y $x *F);
+use Symbol qw(gensym);
+
+# Ensure we do not trigger and tied methods
+tie *F, 'MyTie';
+
+@test = (
+ [ undef, 1],
+ [ undef, 'A'],
+ [ HASH => {} ],
+ [ ARRAY => [] ],
+ [ SCALAR => \$t ],
+ [ REF => \(\$t) ],
+ [ GLOB => \*F ],
+ [ GLOB => gensym ],
+ [ CODE => sub {} ],
+# [ 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";
+ }
+}
+
+package MyTie;
+
+sub TIEHANDLE { bless {} }
+sub DESTROY {}
+
+sub AUTOLOAD {
+ warn "$AUTOLOAD called";
+ exit 1; # May be in an eval
+}
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(sum);
+
+print "1..3\n";
+
+print "not " if defined sum;
+print "ok 1\n";
+
+print "not " unless sum(9) == 9;
+print "ok 2\n";
+
+print "not " unless sum(1,2,3,4) == 10;
+print "ok 3\n";
+
--- /dev/null
+#!./perl -T
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use lib qw(blib/lib blib/arch);
+use Scalar::Util qw(tainted);
+use Config;
+
+print "1..5\n";
+
+print "not " if tainted(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if tainted($var);
+print "ok 2\n";
+
+my $key = (keys %ENV)[0];
+
+$var = $ENV{$key};
+
+print "not " unless tainted($var);
+print "ok 3\n";
+
+print "not " unless tainted($ENV{$key});
+print "ok 4\n";
+
+print "not " if @ARGV and not tainted($ARGV[0]);
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ $|=1;
+ require Scalar::Util;
+ if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
+ print("1..0\n");
+ exit;
+ }
+
+ $DEBUG = 0;
+
+ if ($DEBUG && eval { require Devel::Peek } ) {
+ Devel::Peek->import('Dump');
+ }
+ else {
+ *Dump = sub {};
+ }
+}
+
+use Scalar::Util qw(weaken isweak);
+print "1..17\n";
+
+######################### End of black magic.
+
+$cnt = 0;
+
+sub ok {
+ ++$cnt;
+ if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
+}
+
+$| = 1;
+
+if(1) {
+
+my ($y,$z);
+
+#
+# Case 1: two references, one is weakened, the other is then undef'ed.
+#
+
+{
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+}
+print "# START:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+weaken($y);
+
+print "# WEAK:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+undef($z);
+
+print "# UNDZ:\n";
+Dump($y); Dump($z);
+
+ok( not (defined($y) and defined($z)) );
+undef($y);
+
+print "# UNDY:\n";
+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";
+
+{
+ my $x = "foo";
+ $y = \$x;
+}
+
+ok( $y ne "" );
+print "# BW: \n";
+Dump($y);
+weaken($y);
+print "# AW: \n";
+Dump($y);
+ok( not defined $y );
+
+print "# EXITBLOCK\n";
+}
+
+# exit(0);
+
+#
+# Case 3: a circular structure
+#
+
+# kill 5, $$;
+
+$flag = 0;
+{
+ my $y = bless {}, Dest;
+ Dump($y);
+ print "# 1: $y\n";
+ $y->{Self} = $y;
+ Dump($y);
+ print "# 2: $y\n";
+ $y->{Flag} = \$flag;
+ print "# 3: $y\n";
+ weaken($y->{Self});
+ print "# WKED\n";
+ ok( $y ne "" );
+ print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
+ " FLAG: ",\$y->{Flag},"\n";
+ print "# VPRINT\n";
+}
+print "# OUT $flag\n";
+ok( $flag == 1 );
+
+print "# AFTER\n";
+
+undef $flag;
+
+print "# FLAGU\n";
+
+#
+# Case 4: a more complicated circular structure
+#
+
+$flag = 0;
+{
+ my $y = bless {}, Dest;
+ my $x = bless {}, Dest;
+ $x->{Ref} = $y;
+ $y->{Ref} = $x;
+ $x->{Flag} = \$flag;
+ $y->{Flag} = \$flag;
+ weaken($x->{Ref});
+}
+ok( $flag == 2 );
+
+#
+# Case 5: deleting a weakref before the other one
+#
+
+{
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+}
+
+print "# CASE5\n";
+Dump($y);
+
+weaken($y);
+Dump($y);
+undef($y);
+
+ok( not defined $y);
+ok($z ne "");
+
+
+#
+# Case 6: test isweakref
+#
+
+$a = 5;
+ok(!isweak($a));
+$b = \$a;
+ok(!isweak($b));
+weaken($b);
+ok(isweak($b));
+$b = \$a;
+ok(!isweak($b));
+
+$x = {};
+weaken($x->{Y} = \$a);
+ok(isweak($x->{Y}));
+ok(!isweak($x->{Z}));
+
+
+package Dest;
+
+sub DESTROY {
+ print "# INCFLAG\n";
+ ${$_[0]{Flag}} ++;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff