Add Scalar-List-Utils 1.02, from Graham Barr.

Now we have blessed, reftype, tainted, first, reduce, ...

p4raw-id: //depot/perl@9702

6 files changed, 861 insertions, 0 deletions

diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog
new file mode 100644
index 0000000000..bd9814cacd
--- /dev/null
+++ b/ext/List/Util/ChangeLog
@@ -0,0 +1,85 @@
+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
+
diff --git a/ext/List/Util/Makefile.PL b/ext/List/Util/Makefile.PL
new file mode 100644
index 0000000000..079437b750
--- /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 0000000000..086af5e64d
--- /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 <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.
diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
new file mode 100644
index 0000000000..1997b68129
--- /dev/null
+++ b/ext/List/Util/Util.xs
@@ -0,0 +1,340 @@
+/* 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
+}
diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm
new file mode 100644
index 0000000000..053134d91e
--- /dev/null
+++ b/ext/List/Util/lib/List/Util.pm
@@ -0,0 +1,229 @@
+# 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
diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm
new file mode 100644
index 0000000000..ee65667358
--- /dev/null
+++ b/ext/List/Util/lib/Scalar/Util.pm
@@ -0,0 +1,169 @@
+# 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