+#ifndef PERL_IN_XSUB_RE
+SV*
+Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
+{
+ AV *retarray = NULL;
+ SV *ret;
+ if (flags & 1)
+ retarray=newAV();
+
+ if (from_re || PL_curpm) {
+ const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm);
+ if (rx && rx->paren_names) {
+ HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
+ if (he_str) {
+ IV i;
+ SV* sv_dat=HeVAL(he_str);
+ I32 *nums=(I32*)SvPVX(sv_dat);
+ for ( i=0; i<SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastparen) >= nums[i] &&
+ rx->endp[nums[i]] != -1)
+ {
+ ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
+ if (!retarray)
+ return ret;
+ } else {
+ ret = newSVsv(&PL_sv_undef);
+ }
+ if (retarray) {
+ SvREFCNT_inc(ret);
+ av_push(retarray, ret);
+ }
+ }
+ if (retarray)
+ return (SV*)retarray;
+ }
+ }
+ }
+ return NULL;
+}
+
+SV*
+Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
+{
+ char *s = NULL;
+ I32 i = 0;
+ I32 s1, t1;
+ SV *sv = usesv ? usesv : newSVpvs("");
+ PERL_UNUSED_ARG(flags);
+
+ if (paren == -2 && (s = rx->subbeg) && rx->startp[0] != -1) {
+ /* $` */
+ i = rx->startp[0];
+ }
+ else
+ if (paren == -1 && rx->subbeg && rx->endp[0] != -1) {
+ /* $' */
+ s = rx->subbeg + rx->endp[0];
+ i = rx->sublen - rx->endp[0];
+ }
+ else
+ if ( 0 <= paren && paren <= (I32)rx->nparens &&
+ (s1 = rx->startp[paren]) != -1 &&
+ (t1 = rx->endp[paren]) != -1)
+ {
+ /* $& $1 ... */
+ i = t1 - s1;
+ s = rx->subbeg + s1;
+ }
+
+ if (s) {
+ assert(rx->subbeg);
+ assert(rx->sublen >= (s - rx->subbeg) + i );
+
+ if (i >= 0) {
+ const int oldtainted = PL_tainted;
+ TAINT_NOT;
+ sv_setpvn(sv, s, i);
+ PL_tainted = oldtainted;
+ if ( (rx->extflags & RXf_CANY_SEEN)
+ ? (RX_MATCH_UTF8(rx)
+ && (!i || is_utf8_string((U8*)s, i)))
+ : (RX_MATCH_UTF8(rx)) )
+ {
+ SvUTF8_on(sv);
+ }
+ else
+ SvUTF8_off(sv);
+ if (PL_tainting) {
+ if (RX_MATCH_TAINTED(rx)) {
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ MAGIC* const mg = SvMAGIC(sv);
+ MAGIC* mgt;
+ PL_tainted = 1;
+ SvMAGIC_set(sv, mg->mg_moremagic);
+ SvTAINT(sv);
+ if ((mgt = SvMAGIC(sv))) {
+ mg->mg_moremagic = mgt;
+ SvMAGIC_set(sv, mg);
+ }
+ } else {
+ PL_tainted = 1;
+ SvTAINT(sv);
+ }
+ } else
+ SvTAINTED_off(sv);
+ }
+ } else {
+ sv_setsv(sv,&PL_sv_undef);
+ }
+ } else {
+ sv_setsv(sv,&PL_sv_undef);
+ }
+ return sv;
+}
+#endif
+
+/* Scans the name of a named buffer from the pattern.
+ * If flags is REG_RSN_RETURN_NULL returns null.
+ * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
+ * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
+ * to the parsed name as looked up in the RExC_paren_names hash.
+ * If there is an error throws a vFAIL().. type exception.
+ */
+
+#define REG_RSN_RETURN_NULL 0
+#define REG_RSN_RETURN_NAME 1
+#define REG_RSN_RETURN_DATA 2
+
+STATIC SV*
+S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
+ char *name_start = RExC_parse;
+
+ if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
+ /* skip IDFIRST by using do...while */
+ if (UTF)
+ do {
+ RExC_parse += UTF8SKIP(RExC_parse);
+ } while (isALNUM_utf8((U8*)RExC_parse));
+ else
+ do {
+ RExC_parse++;
+ } while (isALNUM(*RExC_parse));
+ }
+
+ if ( flags ) {
+ SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
+ (int)(RExC_parse - name_start)));
+ if (UTF)
+ SvUTF8_on(sv_name);
+ if ( flags == REG_RSN_RETURN_NAME)
+ return sv_name;
+ else if (flags==REG_RSN_RETURN_DATA) {
+ HE *he_str = NULL;
+ SV *sv_dat = NULL;
+ if ( ! sv_name ) /* should not happen*/
+ Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
+ if (RExC_paren_names)
+ he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
+ if ( he_str )
+ sv_dat = HeVAL(he_str);
+ if ( ! sv_dat )
+ vFAIL("Reference to nonexistent named group");
+ return sv_dat;
+ }
+ else {
+ Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
+ }
+ /* NOT REACHED */
+ }
+ return NULL;
+}
+