From: Jarkko Hietaniemi Date: Sun, 15 Apr 2001 02:07:47 +0000 (+0000) Subject: Add Scalar-List-Utils 1.02, from Graham Barr. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f4a2945e37e7fde9d94fd91ab4bd8581bde8c1ec;p=p5sagit%2Fp5-mst-13.2.git Add Scalar-List-Utils 1.02, from Graham Barr. Now we have blessed, reftype, tainted, first, reduce, ... p4raw-id: //depot/perl@9702 --- diff --git a/MANIFEST b/MANIFEST index a9196bb..50553ad 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,3 +1,22 @@ +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 diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog new file mode 100644 index 0000000..bd9814c --- /dev/null +++ b/ext/List/Util/ChangeLog @@ -0,0 +1,85 @@ +Change 482 on 2000/04/10 by (Graham Barr) + + Check for SvMAGICAL on argument for reftype and blessed + +Change 366 on 2000/03/03 by (Graham Barr) + + Release 1.01 + +Change 365 on 2000/03/03 by (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 (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 (Graham Barr) + + - Better testcase for reftype + +Change 343 on 1999/11/10 by (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 (Graham Barr) + + Updated README + +Change 275 on 1999/03/22 by (Graham Barr) + + Removed forall as it is very broken + +Change 274 on 1999/03/22 by (Graham Barr) + + Added List::Util::forall + +Change 273 on 1999/03/21 by (Graham Barr) + + Added weaken and isweak to Ref::Util + +Change 272 on 1999/03/21 by (Graham Barr) + + Add new .pm files to repository + +Change 271 on 1999/03/21 by (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 (Graham Barr) + + Rename package + +Change 269 on 1999/03/21 by (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 (Graham Barr) + + Modified XS code so it will compile with 5.004 and 5.005 + +Change 115 on 1998/02/21 by (Graham Barr) + + Fri Feb 20 1998 Graham Barr + + t/min.t, t/max.t + - Change sor to do a numerical sort + + Fri Dec 19 1997 Graham Barr + + - Added readonly() + + Wed Nov 19 1997 Graham Barr + + - Initial release + diff --git a/ext/List/Util/Makefile.PL b/ext/List/Util/Makefile.PL new file mode 100644 index 0000000..079437b --- /dev/null +++ b/ext/List/Util/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + VERSION_FROM => "lib/List/Util.pm", + NAME => "List::Util", +); + diff --git a/ext/List/Util/README b/ext/List/Util/README new file mode 100644 index 0000000..086af5e --- /dev/null +++ b/ext/List/Util/README @@ -0,0 +1,31 @@ +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 . All rights reserved. +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs new file mode 100644 index 0000000..1997b68 --- /dev/null +++ b/ext/List/Util/Util.xs @@ -0,0 +1,340 @@ +/* Copyright (c) 1997-2000 Graham Barr . All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + */ + +#include +#include +#include +#include + +#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 +} diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm new file mode 100644 index 0000000..053134d --- /dev/null +++ b/ext/List/Util/lib/List/Util.pm @@ -0,0 +1,229 @@ +# List::Util.pm +# +# Copyright (c) 1997-2000 Graham Barr . 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 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 does not export any subroutines. The +subroutines defined are + +=over 4 + +=item first BLOCK LIST + +Similar to C in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C returns the first element where the result from +BLOCK is a true value. If BLOCK never returns true or LIST was empty then +C 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 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 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 like this + + $foo = reduce { $a > $b ? $a : $b } 1..10 + +=item maxstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the highest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = maxstr 'A'..'Z' # 'Z' + $foo = maxstr "hello","world" # "world" + $foo = maxstr @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' + +=item min LIST + +Similar to C but returns the entry in the list with the lowest +numerical value. If the list is empty then C 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 like this + + $foo = reduce { $a < $b ? $a : $b } 1..10 + +=item minstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the lowest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = maxstr 'A'..'Z' # 'A' + $foo = maxstr "hello","world" # "hello" + $foo = maxstr @bar, @baz # whatever + +This function could be implemented using C 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 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 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 . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm new file mode 100644 index 0000000..ee65667 --- /dev/null +++ b/ext/List/Util/lib/Scalar/Util.pm @@ -0,0 +1,169 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2000 Graham Barr . 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 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 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 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 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 . 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 . 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 diff --git a/t/lib/u-blessed.t b/t/lib/u-blessed.t new file mode 100755 index 0000000..d70e023 --- /dev/null +++ b/t/lib/u-blessed.t @@ -0,0 +1,34 @@ +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"; diff --git a/t/lib/u-dualvar.t b/t/lib/u-dualvar.t new file mode 100755 index 0000000..acee8ad --- /dev/null +++ b/t/lib/u-dualvar.t @@ -0,0 +1,41 @@ +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"; diff --git a/t/lib/u-first.t b/t/lib/u-first.t new file mode 100755 index 0000000..71f3de4 --- /dev/null +++ b/t/lib/u-first.t @@ -0,0 +1,20 @@ +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"; diff --git a/t/lib/u-max.t b/t/lib/u-max.t new file mode 100755 index 0000000..f4873bd --- /dev/null +++ b/t/lib/u-max.t @@ -0,0 +1,25 @@ +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"; diff --git a/t/lib/u-maxstr.t b/t/lib/u-maxstr.t new file mode 100755 index 0000000..7964613 --- /dev/null +++ b/t/lib/u-maxstr.t @@ -0,0 +1,25 @@ +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"; diff --git a/t/lib/u-min.t b/t/lib/u-min.t new file mode 100755 index 0000000..124d88a --- /dev/null +++ b/t/lib/u-min.t @@ -0,0 +1,25 @@ +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"; diff --git a/t/lib/u-minstr.t b/t/lib/u-minstr.t new file mode 100755 index 0000000..12dc2fb --- /dev/null +++ b/t/lib/u-minstr.t @@ -0,0 +1,25 @@ +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"; diff --git a/t/lib/u-readonly.t b/t/lib/u-readonly.t new file mode 100644 index 0000000..5079725 --- /dev/null +++ b/t/lib/u-readonly.t @@ -0,0 +1,41 @@ +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"; diff --git a/t/lib/u-reduce.t b/t/lib/u-reduce.t new file mode 100755 index 0000000..d00dea1 --- /dev/null +++ b/t/lib/u-reduce.t @@ -0,0 +1,25 @@ +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"; diff --git a/t/lib/u-reftype.t b/t/lib/u-reftype.t new file mode 100755 index 0000000..06f9ffb --- /dev/null +++ b/t/lib/u-reftype.t @@ -0,0 +1,50 @@ +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 +} diff --git a/t/lib/u-sum.t b/t/lib/u-sum.t new file mode 100755 index 0000000..9c1c7cb --- /dev/null +++ b/t/lib/u-sum.t @@ -0,0 +1,18 @@ +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"; + diff --git a/t/lib/u-tainted.t b/t/lib/u-tainted.t new file mode 100644 index 0000000..c38cf1a --- /dev/null +++ b/t/lib/u-tainted.t @@ -0,0 +1,33 @@ +#!./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"; diff --git a/t/lib/u-weak.t b/t/lib/u-weak.t new file mode 100755 index 0000000..bab6197 --- /dev/null +++ b/t/lib/u-weak.t @@ -0,0 +1,201 @@ +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}} ++; +}