Real working isnumber and isstring

5 files changed, 72 insertions, 42 deletions

diff --git a/cpan/List-Util/ListUtil.xs b/cpan/List-Util/ListUtil.xs
index 7da9b959d1..efe89ebf7a 100644
--- a/cpan/List-Util/ListUtil.xs
+++ b/cpan/List-Util/ListUtil.xs
@@ -526,6 +526,30 @@ CODE:
 	croak("vstrings are not implemented in this release of perl");
 #endif
 
+void
+isstring(sv)
+       SV *sv
+PROTOTYPE: $
+CODE:
+#if PERL_VERSION > 15 || (PERL_VERSION == 15 && PERL_SUBVERSION >= 1)
+  ST(0) = boolSV(SvIsSTRING(sv));
+  XSRETURN(1);
+#else
+  croak("scalar types are not implemented in this release of perl");
+#endif
+
+void
+isnumber(sv)
+       SV *sv
+PROTOTYPE: $
+CODE:
+#if PERL_VERSION > 15 || (PERL_VERSION == 15 && PERL_SUBVERSION >= 1)
+  ST(0) = boolSV(SvIsNUMBER(sv));
+  XSRETURN(1);
+#else
+  croak("scalar types are not implemented in this release of perl");
+#endif
+
 int
 looks_like_number(sv)
 	SV *sv
diff --git a/cpan/List-Util/lib/Scalar/Util.pm b/cpan/List-Util/lib/Scalar/Util.pm
index 24138ca4d8..1e104ecc01 100644
--- a/cpan/List-Util/lib/Scalar/Util.pm
+++ b/cpan/List-Util/lib/Scalar/Util.pm
@@ -12,7 +12,7 @@ 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);
+@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring isstring isnumber looks_like_number set_prototype);
 $VERSION    = "1.23";
 $VERSION   = eval $VERSION;
 
@@ -20,7 +20,7 @@ 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);
+  push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring isstring isnumber set_prototype);
 }
 
 sub export_fail {
@@ -42,6 +42,11 @@ sub export_fail {
     Carp::croak("Vstrings are not implemented in the version of perl");
   }
 
+  if (grep { /^(isstring|isnumber)$/ } @_ ) {
+    require Carp;
+    Carp::croak("Scalar types are not implemented in the version of perl");
+  }
+
   @_;
 }
 
@@ -74,7 +79,7 @@ Scalar::Util - A selection of general-utility scalar subroutines
 =head1 SYNOPSIS
 
     use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
-                        weaken isvstring looks_like_number set_prototype);
+                        weaken isvstring isstring isnumber looks_like_number set_prototype);
                         # and other useful utils appearing below
 
 =head1 DESCRIPTION
@@ -120,6 +125,31 @@ If EXPR is a scalar which was coded as a vstring the result is true.
     $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
     printf($fmt,$vs);
 
+=item isstring EXPR
+
+If EXPR is a scalar with a value that is originally a string -- that is,
+NOT the result of merely stringifying a numeric value -- the result is true.
+NOTE: This function may return a false positive on globs; this should change.
+
+    $s = "1";
+    $n = 1;
+    isstring $s;  #true
+    isstring $n;  #false
+    $foo = $n . '';
+    isstring $n;  #still false
+
+=item isnumber ExPR
+
+If EXPR is a scalar with a value that is originally a number, even if that
+value has been incidentally stringified, the result is true.
+
+    $s = "1";
+    $n = 1;
+    isnumber $s;  #false
+    isnumber $n;  #true
+    $foo = $n . '';
+    isnumber $n;  #still true
+
 =item isweak EXPR
 
 If EXPR is a scalar which is a weak reference the result is true.
diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index 2c249db9dd..14224bde67 100644
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -1151,7 +1151,7 @@ Data_Dumper_Dumpxs(href, ...)
 		    else
 			(void)SvOK_off(name);
 		
-		    if (SvPOK(name)) {
+		    if (SvPOK(name) || SvPOKp(name)) {
 			if ((SvPVX_const(name))[0] == '*') {
 			    if (SvROK(val)) {
 				switch (SvTYPE(SvRV(val))) {
diff --git a/sv.c b/sv.c
index e3426ad5c2..faf2c662d9 100644
--- a/sv.c
+++ b/sv.c
@@ -1165,42 +1165,9 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
     old_body = SvANY(sv);
 
     /* Copying structures onto other structures that have been neatly zeroed
-       has a subtle gotcha. Consider XPVMG
-
-       +------+------+------+------+------+-------+-------+
-       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
-       +------+------+------+------+------+-------+-------+
-       0      4      8     12     16     20      24      28
-
-       where NVs are aligned to 8 bytes, so that sizeof that structure is
-       actually 32 bytes long, with 4 bytes of padding at the end:
-
-       +------+------+------+------+------+-------+-------+------+
-       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
-       +------+------+------+------+------+-------+-------+------+
-       0      4      8     12     16     20      24      28     32
-
-       so what happens if you allocate memory for this structure:
-
-       +------+------+------+------+------+-------+-------+------+------+...
-       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
-       +------+------+------+------+------+-------+-------+------+------+...
-       0      4      8     12     16     20      24      28     32     36
-
-       zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
-       expect, because you copy the area marked ??? onto GP. Now, ??? may have
-       started out as zero once, but it's quite possible that it isn't. So now,
-       rather than a nicely zeroed GP, you have it pointing somewhere random.
-       Bugs ensue.
-
-       (In fact, GP ends up pointing at a previous GP structure, because the
-       principle cause of the padding in XPVMG getting garbage is a copy of
-       sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
-       this happens to be moot because XPVGV has been re-ordered, with GP
-       no longer after STASH)
-
-       So we are careful and work out the size of used parts of all the
-       structures.  */
+       has a subtle gotcha.  The original structure may have unused padding
+       at the end, which the new structure assigns a meaning to.  So we are
+       careful and work out the size of used parts of all the structures.  */
 
     switch (old_type) {
     case SVt_NULL:
@@ -2716,6 +2683,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
 {
     dVAR;
     register char *s;
+    bool priv = FALSE;
 
     if (!sv) {
 	if (lp)
@@ -2923,6 +2891,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
 	Move(ptr, s, len, char);
 	s += len;
 	*s = '\0';
+	priv = TRUE;
     }
     else if (SvNOKp(sv)) {
 	if (SvTYPE(sv) < SVt_PVNV)
@@ -2944,6 +2913,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
 	if (s[-1] == '.')
 	    *--s = '\0';
 #endif
+	priv = TRUE;
     }
     else {
 	if (isGV_with_GP(sv)) {
@@ -2987,7 +2957,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
 	    *lp = len;
 	SvCUR_set(sv, len);
     }
-    SvPOK_on(sv);
+    if (priv)
+	SvPOKp_on(sv);
+    else
+	SvPOK_on(sv);
     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
 			  PTR2UV(sv),SvPVX_const(sv)));
     if (flags & SV_CONST_RETURN)
diff --git a/sv.h b/sv.h
index c838367d93..7074b0f908 100644
--- a/sv.h
+++ b/sv.h
@@ -52,7 +52,7 @@ typedef enum {
 	SVt_PV,		/* 4 */
 	SVt_PVIV,	/* 5 */
 	SVt_PVNV,	/* 6 */
-	SVt_PVMG,	/* 7 */
+	SVt_PVMG,	/* 7 - first one with magic and blessing */
 	SVt_REGEXP,	/* 8 */
 	/* PVBM was here, before BIND replaced it.  */
 	SVt_PVGV,	/* 9 */
@@ -736,6 +736,9 @@ Set the actual length of the string which is in the SV.  See C<SvIV_set>.
 #define SvNIOK_off(sv)		(SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \
 						  SVp_IOK|SVp_NOK|SVf_IVisUV))
 
+#define SvIsSTRING(sv)		((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_POK)
+#define SvIsNUMBER(sv)		(SvNIOK(sv) && !SvPOK(sv))
+
 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
 #define assert_not_ROK(sv)	({assert(!SvROK(sv) || !SvRV(sv));}),
 #define assert_not_glob(sv)	({assert(!isGV_with_GP(sv));}),