Add SHIFT to Perl tied arrays

diff --git a/src/modules/rlm_perl/rlm_perl.c b/src/modules/rlm_perl/rlm_perl.c
index 95d19b5a2475161f4516c5c5bce2c36f21e879aa..2af5dab533b549dd6dc6ff03e63c115072ab35d9 100644 (file)
--- a/src/modules/rlm_perl/rlm_perl.c
+++ b/src/modules/rlm_perl/rlm_perl.c
@@ -966,6 +966,32 @@ static XS(XS_pairs_POP)
        XSRETURN(1);
 }
 
+/** Called when values are "shifted" off a tied array
+ *
+ * The stack contains just the tied SV
+ */
+static XS(XS_pairs_SHIFT)
+{
+       dXSARGS;
+       fr_pair_t       *vp;
+       fr_perl_pair_t  *parent;
+
+       GET_PAIR_MAGIC(1)
+
+       fr_assert(fr_type_is_leaf(pair_data->da->type));
+
+       parent = pair_data->parent;
+       if (!parent->vp) XSRETURN(0);
+
+       vp = fr_pair_find_by_da(&parent->vp->vp_group, NULL, pair_data->da);
+       if (!vp) XSRETURN(0);
+
+       if (perl_value_marshal(vp, &ST(0)) < 0) XSRETURN(0);
+
+       fr_pair_remove(&parent->vp->vp_group, vp);
+       XSRETURN(1);
+}
+
 static void xs_init(pTHX)
 {
        char const *file = __FILE__;
@@ -999,6 +1025,7 @@ static void xs_init(pTHX)
        newXS("freeradiuspairs::STORESIZE", XS_pairs_STORESIZE, "rlm_perl");
        newXS("freeradiuspairs::PUSH", XS_pairs_PUSH, "rlm_perl");
        newXS("freeradiuspairs::POP", XS_pairs_POP, "rlm_perl");
+       newXS("freeradiuspairs::SHIFT", XS_pairs_SHIFT, "rlm_perl");
 }
 
 /** Convert a list of value boxes to a Perl array for passing to subroutines