From a15456ded8f3d1fb2d67e9e3027b5766cc1c419f Mon Sep 17 00:00:00 2001
From: Brian Fraser <fraserbn@gmail.com>
Date: Mon, 26 Sep 2011 12:56:47 -0700
Subject: [PATCH] pp.c & sv.c: pp_ref UTF8 and null cleanup.

This adds a new function to sv.c, sv_ref, which is a nul-and-UTF8
clean version of sv_reftype. pp_ref now uses that.

sv_ref() not only returns the SV, but also takes in an SV
to modify, so we can say both sv_ref(TARG, obj, TRUE); and
sv = sv_ref(NULL, obj, TRUE);
---
 embed.fnc     |  1 +
 pp.c          |  5 ++---
 sv.c          | 34 +++++++++++++++++++++++++++++-----
 t/op/ref.t    |  4 +++-
 t/uni/bless.t |  5 +----
 5 files changed, 36 insertions(+), 13 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index bf3f90b..dea3bed 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1290,6 +1290,7 @@ Apd	|char*	|sv_recode_to_utf8	|NN SV* sv|NN SV *encoding
 Apd	|bool	|sv_cat_decode	|NN SV* dsv|NN SV *encoding|NN SV *ssv|NN int *offset \
 				|NN char* tstr|int tlen
 ApdR	|const char*	|sv_reftype	|NN const SV *const sv|const int ob
+pd	|SV*	|sv_ref	|NULLOK SV *dst|NN const SV *const sv|const int ob
 Apd	|void	|sv_replace	|NN SV *const sv|NN SV *const nsv
 Apd	|void	|sv_report_used
 Apd	|void	|sv_reset	|NN const char* s|NULLOK HV *const stash
diff --git a/pp.c b/pp.c
index 316b80e..9250751 100644
--- a/pp.c
+++ b/pp.c
@@ -537,7 +537,6 @@ S_refto(pTHX_ SV *sv)
 PP(pp_ref)
 {
     dVAR; dSP; dTARGET;
-    const char *pv;
     SV * const sv = POPs;
 
     if (sv)
@@ -546,8 +545,8 @@ PP(pp_ref)
     if (!sv || !SvROK(sv))
 	RETPUSHNO;
 
-    pv = sv_reftype(SvRV(sv),TRUE);
-    PUSHp(pv, strlen(pv));
+    (void)sv_ref(TARG,SvRV(sv),TRUE);
+    PUSHTARG;
     RETURN;
 }
 
diff --git a/sv.c b/sv.c
index 16226f5..d71f901 100644
--- a/sv.c
+++ b/sv.c
@@ -9099,12 +9099,8 @@ const char *
 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
 {
     PERL_ARGS_ASSERT_SV_REFTYPE;
-
-    /* The fact that I don't need to downcast to char * everywhere, only in ?:
-       inside return suggests a const propagation bug in g++.  */
     if (ob && SvOBJECT(sv)) {
-	char * const name = HvNAME_get(SvSTASH(sv));
-	return name ? name : (char *) "__ANON__";
+	return SvPV_nolen_const(sv_ref(NULL, sv, ob));
     }
     else {
 	switch (SvTYPE(sv)) {
@@ -9142,6 +9138,34 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
 }
 
 /*
+=for apidoc sv_ref
+
+Returns a SV describing what the SV passed in is a reference to.
+
+=cut
+*/
+
+SV *
+Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
+{
+    PERL_ARGS_ASSERT_SV_REF;
+
+    if (!dst)
+        dst = sv_newmortal();
+
+    if (ob && SvOBJECT(sv)) {
+	HvNAME_get(SvSTASH(sv))
+                    ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
+                    : sv_setpvn(dst, "__ANON__", 8);
+    }
+    else {
+        const char * reftype = sv_reftype(sv, 0);
+        sv_setpv(dst, reftype);
+    }
+    return dst;
+}
+
+/*
 =for apidoc sv_isobject
 
 Returns a boolean indicating whether the SV is an RV pointing to a blessed
diff --git a/t/op/ref.t b/t/op/ref.t
index 75fb275..c607a60 100644
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -8,7 +8,7 @@ BEGIN {
 
 use strict qw(refs subs);
 
-plan(222);
+plan(223);
 
 # Test glob operations.
 
@@ -769,6 +769,8 @@ SKIP:{
 }
 
 
+is ref( bless {}, "nul\0clean" ), "nul\0clean", "ref() is nul-clean";
+
 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 $test = curr_test();
 curr_test($test + 3);
diff --git a/t/uni/bless.t b/t/uni/bless.t
index b4cdb68..5475f3e 100644
--- a/t/uni/bless.t
+++ b/t/uni/bless.t
@@ -13,10 +13,7 @@ plan (84);
 sub expected {
     my($object, $package, $type) = @_;
     print "# $object $package $type\n";
-    TODO: {
-        local $TODO = "ref not yet clean";
-        is(ref($object), $package);
-    }
+    is(ref($object), $package);
     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/u;
     like("$object", $r);
     if ("$object" =~ $r) {
-- 
1.8.3.1