Add new API function sv_rvunweaken

Needed to fix in-place sort of weak references in a future commit.

Stolen from Scalar::Util::unweaken, which will be made to use this
when available via CPAN upstream.

diff --git a/embed.fnc b/embed.fnc
index b0a362b..40606f6 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1980,6 +1980,7 @@ Apdmb     |void   |sv_force_normal|NN SV *sv
 Apd    |void   |sv_force_normal_flags|NN SV *const sv|const U32 flags
 pX     |SSize_t|tmps_grow_p    |SSize_t ix
 Apd    |SV*    |sv_rvweaken    |NN SV *const sv
+Apd    |SV*    |sv_rvunweaken  |NN SV *const sv
 AnpMd  |SV*    |sv_get_backrefs|NN SV *const sv
 : This is indirectly referenced by globals.c. This is somewhat annoying.
 p      |int    |magic_killbackrefs|NN SV *sv|NN MAGIC *mg

diff --git a/embed.h b/embed.h
index a28d1c8..23b1448 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -663,6 +663,7 @@
 #define sv_replace(a,b)                Perl_sv_replace(aTHX_ a,b)
 #define sv_report_used()       Perl_sv_report_used(aTHX)
 #define sv_reset(a,b)          Perl_sv_reset(aTHX_ a,b)
+#define sv_rvunweaken(a)       Perl_sv_rvunweaken(aTHX_ a)
 #define sv_rvweaken(a)         Perl_sv_rvweaken(aTHX_ a)
 #define sv_set_undef(a)                Perl_sv_set_undef(aTHX_ a)
 #define sv_setiv(a,b)          Perl_sv_setiv(aTHX_ a,b)

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index c05d00a..7a7b220 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1524,6 +1524,11 @@ expression pattern.  Trying to do this in ordinary Perl code produces a
 value that prints out looking like SCALAR(0xdecaf).  Use the $1 form
 instead.
 
+=item Can't unweaken a nonreference
+
+(F) You attempted to unweaken something that was not a reference.  Only
+references can be unweakened.
+
 =item Can't weaken a nonreference
 
 (F) You attempted to weaken something that was not a reference.  Only
@@ -5204,6 +5209,11 @@ to use parens.  In any case, a hash requires key/value B<pairs>.
 (W misc) You have attempted to weaken a reference that is already weak.
 Doing so has no effect.
 
+=item Reference is not weak
+
+(W misc) You have attempted to unweaken a reference that is not weak.
+Doing so has no effect.
+
 =item Reference to invalid group 0 in regex; marked by S<<-- HERE> in m/%s/
 
 (F) You used C<\g0> or similar in a regular expression.  You may refer

diff --git a/proto.h b/proto.h
index 9822512..a9de746 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3297,6 +3297,9 @@ PERL_CALLCONV void        Perl_sv_reset(pTHX_ const char* s, HV *const stash);
 #define PERL_ARGS_ASSERT_SV_RESET      \
        assert(s)
 PERL_CALLCONV void     Perl_sv_resetpvn(pTHX_ const char* s, STRLEN len, HV *const stash);
+PERL_CALLCONV SV*      Perl_sv_rvunweaken(pTHX_ SV *const sv);
+#define PERL_ARGS_ASSERT_SV_RVUNWEAKEN \
+       assert(sv)
 PERL_CALLCONV SV*      Perl_sv_rvweaken(pTHX_ SV *const sv);
 #define PERL_ARGS_ASSERT_SV_RVWEAKEN   \
        assert(sv)

diff --git a/sv.c b/sv.c
index c370f97..9751ea6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5961,7 +5961,8 @@ Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
 push a back-reference to this RV onto the array of backreferences
 associated with that magic.  If the RV is magical, set magic will be
-called after the RV is cleared.
+called after the RV is cleared.  Silently ignores C<undef> and warns
+on already-weak references.
 
 =cut
 */
@@ -5990,6 +5991,42 @@ Perl_sv_rvweaken(pTHX_ SV *const sv)
 }
 
 /*
+=for apidoc sv_rvunweaken
+
+Unweaken a reference: Clear the C<SvWEAKREF> flag on this RV; remove
+the backreference to this RV from the array of backreferences
+associated with the target SV, increment the refcount of the target.
+Silently ignores C<undef> and warns on non-weak references.
+
+=cut
+*/
+
+SV *
+Perl_sv_rvunweaken(pTHX_ SV *const sv)
+{
+    SV *tsv;
+
+    PERL_ARGS_ASSERT_SV_RVUNWEAKEN;
+
+    if (!SvOK(sv)) /* let undefs pass */
+        return sv;
+    if (!SvROK(sv))
+        Perl_croak(aTHX_ "Can't unweaken a nonreference");
+    else if (!SvWEAKREF(sv)) {
+        Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is not weak");
+        return sv;
+    }
+    else if (SvREADONLY(sv)) croak_no_modify();
+
+    tsv = SvRV(sv);
+    SvWEAKREF_off(sv);
+    SvROK_on(sv);
+    SvREFCNT_inc_NN(tsv);
+    Perl_sv_del_backref(aTHX_ tsv, sv);
+    return sv;
+}
+
+/*
 =for apidoc sv_get_backrefs
 
 If C<sv> is the target of a weak reference then it returns the back