From 70b71ec84c6ce44565d910f531ad659af12a4c35 Mon Sep 17 00:00:00 2001
From: Brian Fraser <fraserbn@gmail.com>
Date: Wed, 5 Oct 2011 23:56:03 -0700
Subject: [PATCH] Add a sv_sethek() function to sv.c

This is exported so that attributes.xs can use it.
---
 embed.fnc |  1 +
 embed.h   |  1 +
 proto.h   |  5 +++++
 sv.c      | 43 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 50 insertions(+)

diff --git a/embed.fnc b/embed.fnc
index cdb5f85..bf3f90b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1308,6 +1308,7 @@ Apd	|SV*	|sv_setref_pvn	|NN SV *const rv|NULLOK const char *const classname \
 				|NN const char *const pv|const STRLEN n
 Apd	|void	|sv_setpv	|NN SV *const sv|NULLOK const char *const ptr
 Apd	|void	|sv_setpvn	|NN SV *const sv|NULLOK const char *const ptr|const STRLEN len
+Xp	|void	|sv_sethek	|NN SV *const sv|NULLOK const HEK *const hek
 Amdb	|void	|sv_setsv	|NN SV *dstr|NULLOK SV *sstr
 Amdb	|void	|sv_taint	|NN SV* sv
 ApdR	|bool	|sv_tainted	|NN SV *const sv
diff --git a/embed.h b/embed.h
index 9f31a16..fde7a9c 100644
--- a/embed.h
+++ b/embed.h
@@ -1166,6 +1166,7 @@
 #define sv_clean_objs()		Perl_sv_clean_objs(aTHX)
 #define sv_del_backref(a,b)	Perl_sv_del_backref(aTHX_ a,b)
 #define sv_free_arenas()	Perl_sv_free_arenas(aTHX)
+#define sv_sethek(a,b)		Perl_sv_sethek(aTHX_ a,b)
 #ifndef PERL_IMPLICIT_CONTEXT
 #define tied_method		Perl_tied_method
 #endif
diff --git a/proto.h b/proto.h
index 7fdfdcb..0b9f5a6 100644
--- a/proto.h
+++ b/proto.h
@@ -4028,6 +4028,11 @@ PERL_CALLCONV SV*	Perl_sv_rvweaken(pTHX_ SV *const sv)
 #define PERL_ARGS_ASSERT_SV_RVWEAKEN	\
 	assert(sv)
 
+PERL_CALLCONV void	Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETHEK	\
+	assert(sv)
+
 PERL_CALLCONV void	Perl_sv_setiv(pTHX_ SV *const sv, const IV num)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_SETIV	\
diff --git a/sv.c b/sv.c
index 8f7d53c..16226f5 100644
--- a/sv.c
+++ b/sv.c
@@ -4580,6 +4580,49 @@ Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
     SvSETMAGIC(sv);
 }
 
+void
+Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
+{
+    dVAR;
+
+    PERL_ARGS_ASSERT_SV_SETHEK;
+
+    if (!hek) {
+	return;
+    }
+
+    if (HEK_LEN(hek) == HEf_SVKEY) {
+	sv_setsv(sv, *(SV**)HEK_KEY(hek));
+        return;
+    } else {
+	const int flags = HEK_FLAGS(hek);
+	if (flags & HVhek_WASUTF8) {
+	    STRLEN utf8_len = HEK_LEN(hek);
+	    char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
+	    sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
+	    SvUTF8_on(sv);
+            return;
+	} else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
+	    sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
+	    if (HEK_UTF8(hek))
+		SvUTF8_on(sv);
+            return;
+	}
+        {
+	    sv_upgrade(sv, SVt_PV);
+	    sv_usepvn_flags(sv, (char *)HEK_KEY(share_hek_hek(hek)), HEK_LEN(hek), SV_HAS_TRAILING_NUL);
+	    SvLEN_set(sv, 0);
+	    SvREADONLY_on(sv);
+	    SvFAKE_on(sv);
+	    SvPOK_on(sv);
+	    if (HEK_UTF8(hek))
+		SvUTF8_on(sv);
+            return;
+	}
+    }
+}
+
+
 /*
 =for apidoc sv_usepvn_flags
 
-- 
1.8.3.1