From: Nick Porter <nick@portercomputing.co.uk>
Date: Fri, 16 May 2025 19:18:01 +0000 (+0100)
Subject: Add UNSHIFT to Perl tied arrays
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=2415a6a7faf4af50fbf123887ce67cfd35d47566;p=thirdparty%2Ffreeradius-server.git

Add UNSHIFT to Perl tied arrays
---

diff --git a/src/modules/rlm_perl/rlm_perl.c b/src/modules/rlm_perl/rlm_perl.c
index 2af5dab533b..6aa2838c1c4 100644
--- a/src/modules/rlm_perl/rlm_perl.c
+++ b/src/modules/rlm_perl/rlm_perl.c
@@ -992,6 +992,36 @@ static XS(XS_pairs_SHIFT)
 	XSRETURN(1);
 }
 
+/** Called when values are "unshifted" onto a tied array
+ *
+ * The stack contains
+ *  - the tied SV
+ *  - one or more values being shifted onto the array
+ */
+static XS(XS_pairs_UNSHIFT)
+{
+	dXSARGS;
+	int		i = 1;
+	fr_pair_t	*vp;
+	fr_perl_pair_t	*parent;
+
+	GET_PAIR_MAGIC(2)
+
+	fr_assert(fr_type_is_leaf(pair_data->da->type));
+
+	parent = pair_data->parent;
+	if (!parent->vp) {
+		if (fr_perl_pair_parent_build(parent) < 0) XSRETURN(0);
+	}
+
+	while (i < items) {
+		fr_pair_prepend_by_da(parent->vp, &vp, &parent->vp->vp_group, pair_data->da);
+		if (perl_value_unmarshal(vp, ST(i++)) < 0) break;
+	}
+
+	XSRETURN(0);
+}
+
 static void xs_init(pTHX)
 {
 	char const *file = __FILE__;
@@ -1026,6 +1056,7 @@ static void xs_init(pTHX)
 	newXS("freeradiuspairs::PUSH", XS_pairs_PUSH, "rlm_perl");
 	newXS("freeradiuspairs::POP", XS_pairs_POP, "rlm_perl");
 	newXS("freeradiuspairs::SHIFT", XS_pairs_SHIFT, "rlm_perl");
+	newXS("freeradiuspairs::UNSHIFT", XS_pairs_UNSHIFT, "rlm_perl");
 }
 
 /** Convert a list of value boxes to a Perl array for passing to subroutines