#if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
#  define DEBUGGING
#  define DEBUGGING_RE_ONLY
#endif

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "re_comp.h"

#undef dXSBOOTARGSXSAPIVERCHK
/* skip API version checking due to different interp struct size but,
   this hack is until GitHub issue #14169 is resolved */
#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK

START_EXTERN_C

extern REGEXP*	my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags);
extern REGEXP*	my_re_op_compile (pTHX_ SV ** const patternp, int pat_count,
		    OP *expr, const regexp_engine* eng, REGEXP *volatile old_re,
		     bool *is_bare_re, U32 rx_flags, U32 pm_flags);

extern I32	my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend,
			    char* strbeg, SSize_t minend, SV* screamer,
			    void* data, U32 flags);

extern char*	my_re_intuit_start(pTHX_
                    REGEXP * const rx,
                    SV *sv,
                    const char * const strbeg,
                    char *strpos,
                    char *strend,
                    const U32 flags,
                    re_scream_pos_data *data);

extern SV*	my_re_intuit_string (pTHX_ REGEXP * const prog);

extern void	my_regfree (pTHX_ REGEXP * const r);

extern void	my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
					   SV * const usesv);
extern void	my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
					   SV const * const value);
extern I32	my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
					    const SV * const sv, const I32 paren);

extern SV*	my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
                              const U32);
extern SV*	my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
                                   const SV * const lastkey, const U32 flags);

extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
#if defined(USE_ITHREADS)
extern void*	my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
#endif
extern void     my_regprop(pTHX_
    const regexp *prog, SV* sv, const regnode* o,
    const regmatch_info *reginfo, const RExC_state_t *pRExC_state
);

EXTERN_C const struct regexp_engine my_reg_engine;
EXTERN_C const struct regexp_engine wild_reg_engine;

END_EXTERN_C

const struct regexp_engine my_reg_engine = { 
        my_re_compile, 
        my_regexec, 
        my_re_intuit_start, 
        my_re_intuit_string, 
        my_regfree, 
        my_reg_numbered_buff_fetch,
        my_reg_numbered_buff_store,
        my_reg_numbered_buff_length,
        my_reg_named_buff,
        my_reg_named_buff_iter,
        my_reg_qr_package,
#if defined(USE_ITHREADS)
        my_regdupe,
#endif
        my_re_op_compile,
};

/* For use with Unicode property wildcards, when we want to see the compilation
 * of the wildcard subpattern, but don't want to see the matching process.  All
 * but the compilation are the regcomp.c/regexec.c functions which aren't
 * subject to 'use re' */
const struct regexp_engine wild_reg_engine = {
        my_re_compile,
        Perl_regexec_flags,
        Perl_re_intuit_start,
        Perl_re_intuit_string,
        Perl_regfree_internal,
        Perl_reg_numbered_buff_fetch,
        Perl_reg_numbered_buff_store,
        Perl_reg_numbered_buff_length,
        Perl_reg_named_buff,
        Perl_reg_named_buff_iter,
        Perl_reg_qr_package,
#if defined(USE_ITHREADS)
        Perl_regdupe_internal,
#endif
        my_re_op_compile,
};

#define newSVbool_(x) newSViv((x) ? 1 : 0)

MODULE = re	PACKAGE = re

void
install()
    PPCODE:
        PL_colorset = 0;	/* Allow reinspection of ENV. */
        /* PL_debug |= DEBUG_r_FLAG; */
	XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));

void
regmust(sv)
    SV * sv
PROTOTYPE: $
PREINIT:
    REGEXP *re;
PPCODE:
{
    if ((re = SvRX(sv)) /* assign deliberate */
       /* only for re engines we know about */
       && (   RX_ENGINE(re) == &my_reg_engine
           || RX_ENGINE(re) == &wild_reg_engine
           || RX_ENGINE(re) == &PL_core_reg_engine))
    {
        SV *an = &PL_sv_no;
        SV *fl = &PL_sv_no;
        if (RX_ANCHORED_SUBSTR(re)) {
            an = sv_2mortal(newSVsv(RX_ANCHORED_SUBSTR(re)));
        } else if (RX_ANCHORED_UTF8(re)) {
            an = sv_2mortal(newSVsv(RX_ANCHORED_UTF8(re)));
        }
        if (RX_FLOAT_SUBSTR(re)) {
            fl = sv_2mortal(newSVsv(RX_FLOAT_SUBSTR(re)));
        } else if (RX_FLOAT_UTF8(re)) {
            fl = sv_2mortal(newSVsv(RX_FLOAT_UTF8(re)));
        }
        EXTEND(SP, 2);
        PUSHs(an);
        PUSHs(fl);
        XSRETURN(2);
    }
    XSRETURN_UNDEF;
}

SV *
optimization(sv)
    SV * sv
PROTOTYPE: $
PREINIT:
    REGEXP *re;
    regexp *r;
    struct reg_substr_datum * data;
    HV *hv;
CODE:
{
    re = SvRX(sv);
    if (!re) {
        XSRETURN_UNDEF;
    }

    /* only for re engines we know about */
    if (   RX_ENGINE(re) != &my_reg_engine
        && RX_ENGINE(re) != &wild_reg_engine
        && RX_ENGINE(re) != &PL_core_reg_engine)
    {
        XSRETURN_UNDEF;
    }

    if (!PL_colorset) {
        reginitcolors();
    }

    r = ReANY(re);
    hv = newHV();

    hv_stores(hv, "minlen", newSViv(r->minlen));
    hv_stores(hv, "minlenret", newSViv(r->minlenret));
    hv_stores(hv, "gofs", newSViv(r->gofs));

    data = &r->substrs->data[0];
    hv_stores(hv, "anchored", data->substr
            ? newSVsv(data->substr) : &PL_sv_undef);
    hv_stores(hv, "anchored utf8", data->utf8_substr
            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
    hv_stores(hv, "anchored min offset", newSViv(data->min_offset));
    hv_stores(hv, "anchored max offset", newSViv(data->max_offset));
    hv_stores(hv, "anchored end shift", newSViv(data->end_shift));

    data = &r->substrs->data[1];
    hv_stores(hv, "floating", data->substr
            ? newSVsv(data->substr) : &PL_sv_undef);
    hv_stores(hv, "floating utf8", data->utf8_substr
            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
    hv_stores(hv, "floating min offset", newSViv(data->min_offset));
    hv_stores(hv, "floating max offset", newSViv(data->max_offset));
    hv_stores(hv, "floating end shift", newSViv(data->end_shift));

    hv_stores(hv, "checking", newSVpv(
        (!r->check_substr && !r->check_utf8)
            ? "none"
        : (    r->check_substr == r->substrs->data[1].substr
            && r->check_utf8   == r->substrs->data[1].utf8_substr
        )
            ? "floating"
        : "anchored"
    , 0));

    hv_stores(hv, "noscan", newSVbool_(r->intflags & PREGf_NOSCAN));
    hv_stores(hv, "isall", newSVbool_(r->extflags & RXf_CHECK_ALL));
    hv_stores(hv, "anchor SBOL", newSVbool_(r->intflags & PREGf_ANCH_SBOL));
    hv_stores(hv, "anchor MBOL", newSVbool_(r->intflags & PREGf_ANCH_MBOL));
    hv_stores(hv, "anchor GPOS", newSVbool_(r->intflags & PREGf_ANCH_GPOS));
    hv_stores(hv, "skip", newSVbool_(r->intflags & PREGf_SKIP));
    hv_stores(hv, "implicit", newSVbool_(r->intflags & PREGf_IMPLICIT));

    {
        RXi_GET_DECL(r, ri);
        if (ri->regstclass) {
            SV* sv = newSV(0);
            /* not Perl_regprop, we must have the DEBUGGING version */
            my_regprop(aTHX_ r, sv, ri->regstclass, NULL, NULL);
            hv_stores(hv, "stclass", sv);
        } else {
            hv_stores(hv, "stclass", &PL_sv_undef);
        }
    }

    RETVAL = newRV_noinc((SV *)hv);
}
OUTPUT:
    RETVAL

#
# ex: set ts=8 sts=4 sw=4 et:
#