[p5sagit/p5-mst-13.2.git] / ext / re / re.xs

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

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


START_EXTERN_C

extern regexp*	my_re_compile (pTHX_ char* exp, char* xend, PMOP* pm);
extern I32	my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
			    char* strbeg, I32 minend, SV* screamer,
			    void* data, U32 flags);

extern char*	my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos,
				    char *strend, U32 flags,
				    struct re_scream_pos_data_s *data);
extern SV*	my_re_intuit_string (pTHX_ regexp *prog);

extern void	my_regfree (pTHX_ struct regexp* r);
extern SV*      my_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv);
extern SV*      my_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags);
#if defined(USE_ITHREADS)
extern void*	my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
#endif

EXTERN_C const struct regexp_engine my_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_get,
        my_reg_named_buff_get,
#if defined(USE_ITHREADS)
        my_regdupe 
#endif
};

regexp *
get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
    MAGIC *mg;
    if (sv) {
        if (SvMAGICAL(sv))
            mg_get(sv);
        if (SvROK(sv) &&
            (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
            SvTYPE(sv) == SVt_PVMG &&
            (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
        {        
            if (mgp) *mgp = mg;
            return (regexp *)mg->mg_obj;       
        }
    }    
    if (mgp) *mgp = NULL;
    return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
}

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
is_regexp(sv)
    SV * sv
PROTOTYPE: $
PPCODE:
{
    if ( get_re_arg( aTHX_ sv, 0, NULL ) ) 
    {
        XSRETURN_YES;
    } else {
        XSRETURN_NO;
    }
    /* NOTREACHED */        
}        
	
void
regexp_pattern(sv)
    SV * sv
PROTOTYPE: $
PREINIT:
    MAGIC *mg;
    regexp *re;
PPCODE:
{
    /*
       Checks if a reference is a regex or not. If the parameter is
       not a ref, or is not the result of a qr// then returns false
       in scalar context and an empty list in list context.
       Otherwise in list context it returns the pattern and the
       modifiers, in scalar context it returns the pattern just as it
       would if the qr// was stringified normally, regardless as
       to the class of the variable and any strigification overloads
       on the object. 
    */

    if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
    {
        /* Housten, we have a regex! */
        SV *pattern;
        STRLEN patlen = 0;
        STRLEN left = 0;
        char reflags[6];
        
        if ( GIMME_V == G_ARRAY ) {
            /*
               we are in list context so stringify
               the modifiers that apply. We ignore "negative
               modifiers" in this scenario. 
            */

            char *fptr = INT_PAT_MODS;
            char ch;
            U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);

            while((ch = *fptr++)) {
                if(match_flags & 1) {
                    reflags[left++] = ch;
                }
                match_flags >>= 1;
            }

            pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
            if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);

            /* return the pattern and the modifiers */
            XPUSHs(pattern);
            XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
            XSRETURN(2);
        } else {
            /* Scalar, so use the string that Perl would return */
            /* return the pattern in (?msix:..) format */
            pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
            if (re->extflags & RXf_UTF8) 
                SvUTF8_on(pattern);
            XPUSHs(pattern);
            XSRETURN(1);
        }
    } else {
        /* It ain't a regexp folks */
        if ( GIMME_V == G_ARRAY ) {
            /* return the empty list */
            XSRETURN_UNDEF;
        } else {
            /* Because of the (?:..) wrapping involved in a 
               stringified pattern it is impossible to get a 
               result for a real regexp that would evaluate to 
               false. Therefore we can return PL_sv_no to signify
               that the object is not a regex, this means that one 
               can say
               
                 if (regex($might_be_a_regex) eq '(?:foo)') { }
               
               and not worry about undefined values.
            */
            XSRETURN_NO;
        }    
    }
    /* NOT-REACHED */
}


void
regmust(sv)
    SV * sv
PROTOTYPE: $
PREINIT:
    regexp *re;
PPCODE:
{
    if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
    {
        SV *an = &PL_sv_no;
        SV *fl = &PL_sv_no;
        if (re->anchored_substr) {
            an = newSVsv(re->anchored_substr);
        } else if (re->anchored_utf8) {
            an = newSVsv(re->anchored_utf8);
        }
        if (re->float_substr) {
            fl = newSVsv(re->float_substr);
        } else if (re->float_utf8) {
            fl = newSVsv(re->float_utf8);
        }
        XPUSHs(an);
        XPUSHs(fl);
        XSRETURN(2);
    }
    XSRETURN_UNDEF;
}

void
regname(sv, qr = NULL, all = NULL)
    SV * sv
    SV * qr
    SV * all
PROTOTYPE: ;$$$
PREINIT:
    regexp *re = NULL;
    SV *bufs = NULL;
PPCODE:
{
    re = get_re_arg( aTHX_ qr, 1, NULL);
    if (SvPOK(sv) && re && re->paren_names) {
        bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
        if (bufs) {
            if (all && SvTRUE(all))
                XPUSHs(newRV(bufs));
            else
                XPUSHs(SvREFCNT_inc(bufs));
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}        
    
void
regnames(sv = NULL, all = NULL)
    SV *sv
    SV *all
PROTOTYPE: ;$$
PREINIT:
    regexp *re = NULL;
    IV count = 0;
PPCODE:
{
    re = get_re_arg( aTHX_  sv, 1, NULL );
    if (re && re->paren_names) {
        HV *hv= re->paren_names;
        (void)hv_iterinit(hv);
        while (1) {
            HE *temphe = hv_iternext_flags(hv,0);
            if (temphe) {
                IV i;
                IV parno = 0;
                SV* sv_dat = HeVAL(temphe);
                I32 *nums = (I32*)SvPVX(sv_dat);
                for ( i = 0; i < SvIVX(sv_dat); i++ ) {
                    if ((I32)(re->lastcloseparen) >= nums[i] &&
                        re->startp[nums[i]] != -1 &&
                        re->endp[nums[i]] != -1)
                    {
                        parno = nums[i];
                        break;
                    }
                }
                if (parno || (all && SvTRUE(all))) {
                    STRLEN len;
                    char *pv = HePV(temphe, len);
                    if ( GIMME_V == G_ARRAY ) 
                        XPUSHs(newSVpvn(pv,len));
                    count++;
                }
            } else {
                break;
            }
        }
    }
    if ( GIMME_V == G_ARRAY ) 
        XSRETURN(count);
    else 
        XSRETURN_UNDEF;
}    

void
regnames_iterinit(sv = NULL)
    SV * sv
PROTOTYPE: ;$
PREINIT:
    regexp *re = NULL;
PPCODE:
{
    re = get_re_arg( aTHX_  sv, 1, NULL );
    if (re && re->paren_names) {
        (void)hv_iterinit(re->paren_names);
        XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
    } else {
        XSRETURN_UNDEF;
    }  
}

void
regnames_iternext(sv = NULL, all = NULL)
    SV *sv
    SV *all
PROTOTYPE: ;$$
PREINIT:
    regexp *re;
PPCODE:
{
    re = get_re_arg( aTHX_  sv, 1, NULL ); 
    if (re && re->paren_names) {
        HV *hv= re->paren_names;
        while (1) {
            HE *temphe = hv_iternext_flags(hv,0);
            if (temphe) {
                IV i;
                IV parno = 0;
                SV* sv_dat = HeVAL(temphe);
                I32 *nums = (I32*)SvPVX(sv_dat);
                for ( i = 0; i < SvIVX(sv_dat); i++ ) {
                    if ((I32)(re->lastcloseparen) >= nums[i] &&
                        re->startp[nums[i]] != -1 &&
                        re->endp[nums[i]] != -1)
                    {
                        parno = nums[i];
                        break;
                    }
                }
                if (parno || (all && SvTRUE(all))) {
                    STRLEN len;
                    char *pv = HePV(temphe, len);
                    XPUSHs(newSVpvn(pv,len));
                    XSRETURN(1);    
                }
            } else {
                break;
            }
        }
    }
    XSRETURN_UNDEF;
}    

void
regnames_count(sv = NULL)
    SV * sv
PROTOTYPE: ;$
PREINIT:
    regexp *re = NULL;
PPCODE:
{
    re = get_re_arg( aTHX_  sv, 1, NULL );
    if (re && re->paren_names) {
        XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
    } else {
        XSRETURN_UNDEF;
    }  
}
Commit	Line	Data
41b16711	1	#if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
	2	# define DEBUGGING
	3	#endif
	4
c5be433b	5	#define PERL_NO_GET_CONTEXT
56953603	6	#include "EXTERN.h"
	7	#include "perl.h"
	8	#include "XSUB.h"
256ddcd0	9	#include "re_comp.h"
56953603	10
f9f4320a	11
97f88e98	12	START_EXTERN_C
97f88e98	13
6d5c990f	14	extern regexp* my_re_compile (pTHX_ char* exp, char* xend, PMOP* pm);
cea2e8a9	15	extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
20ce7b12	16	char* strbeg, I32 minend, SV* screamer,
20ce7b12	17	void* data, U32 flags);
f8149455	18
f722798b	19	extern char* my_re_intuit_start (pTHX_ regexp prog, SV sv, char *strpos,
	20	char *strend, U32 flags,
	21	struct re_scream_pos_data_s *data);
	22	extern SV* my_re_intuit_string (pTHX_ regexp *prog);
56953603	23
f8149455	24	extern void my_regfree (pTHX_ struct regexp* r);
93b32b6d	25	extern SV* my_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv);
93b32b6d	26	extern SV* my_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags);
a3c0e9ca	27	#if defined(USE_ITHREADS)
9f33bf00	28	extern void* my_regdupe (pTHX_ const regexp r, CLONE_PARAMS param);
a3c0e9ca	29	#endif
0a28d81c	30
70685ca0	31	EXTERN_C const struct regexp_engine my_reg_engine;
	32
	33	END_EXTERN_C
	34
	35	const struct regexp_engine my_reg_engine = {
6d5c990f	36	my_re_compile,
f9f4320a	37	my_regexec,
	38	my_re_intuit_start,
	39	my_re_intuit_string,
	40	my_regfree,
93b32b6d	41	my_reg_numbered_buff_get,
93b32b6d	42	my_reg_named_buff_get,
a3c0e9ca	43	#if defined(USE_ITHREADS)
f9f4320a	44	my_regdupe
a3c0e9ca	45	#endif
0a28d81c	46	};
0a28d81c	47
44a2ac75	48	regexp *
	49	get_re_arg( pTHX_ SV sv, U32 flags, MAGIC *mgp) {
	50	MAGIC *mg;
	51	if (sv) {
	52	if (SvMAGICAL(sv))
	53	mg_get(sv);
	54	if (SvROK(sv) &&
	55	(sv = (SV)SvRV(sv)) && / assign deliberate */
	56	SvTYPE(sv) == SVt_PVMG &&
	57	(mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
	58	{
	59	if (mgp) *mgp = mg;
	60	return (regexp *)mg->mg_obj;
	61	}
	62	}
	63	if (mgp) *mgp = NULL;
	64	return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
	65	}
	66
56953603	67	MODULE = re PACKAGE = re
	68
	69	void
f9f4320a	70	install()
	71	PPCODE:
	72	PL_colorset = 0; /* Allow reinspection of ENV. */
	73	/* PL_debug \|= DEBUG_r_FLAG; */
	74	XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
	75
de8c5301	76
	77	void
	78	is_regexp(sv)
	79	SV * sv
	80	PROTOTYPE: $
de8c5301	81	PPCODE:
de8c5301	82	{
44a2ac75	83	if ( get_re_arg( aTHX_ sv, 0, NULL ) )
de8c5301	84	{
	85	XSRETURN_YES;
	86	} else {
	87	XSRETURN_NO;
	88	}
	89	/* NOTREACHED */
	90	}
	91
	92	void
	93	regexp_pattern(sv)
	94	SV * sv
	95	PROTOTYPE: $
	96	PREINIT:
	97	MAGIC *mg;
44a2ac75	98	regexp *re;
de8c5301	99	PPCODE:
	100	{
	101	/*
	102	Checks if a reference is a regex or not. If the parameter is
	103	not a ref, or is not the result of a qr// then returns false
	104	in scalar context and an empty list in list context.
	105	Otherwise in list context it returns the pattern and the
	106	modifiers, in scalar context it returns the pattern just as it
	107	would if the qr// was stringified normally, regardless as
	108	to the class of the variable and any strigification overloads
	109	on the object.
	110	*/
	111
44a2ac75	112	if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
de8c5301	113	{
de8c5301	114	/* Housten, we have a regex! */
de8c5301	115	SV *pattern;
de8c5301	116	STRLEN patlen = 0;
	117	STRLEN left = 0;
	118	char reflags[6];
	119
	120	if ( GIMME_V == G_ARRAY ) {
	121	/*
	122	we are in list context so stringify
	123	the modifiers that apply. We ignore "negative
	124	modifiers" in this scenario.
	125	*/
	126
bcdf7404	127	char *fptr = INT_PAT_MODS;
de8c5301	128	char ch;
bbe252da	129	U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
de8c5301	130
de8c5301	131	while((ch = *fptr++)) {
bbe252da	132	if(match_flags & 1) {
de8c5301	133	reflags[left++] = ch;
de8c5301	134	}
bbe252da	135	match_flags >>= 1;
de8c5301	136	}
	137
	138	pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
bbe252da	139	if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
de8c5301	140
	141	/* return the pattern and the modifiers */
	142	XPUSHs(pattern);
	143	XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
	144	XSRETURN(2);
	145	} else {
	146	/* Scalar, so use the string that Perl would return */
de8c5301	147	/* return the pattern in (?msix:..) format */
bcdf7404	148	pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
bbe252da	149	if (re->extflags & RXf_UTF8)
de8c5301	150	SvUTF8_on(pattern);
	151	XPUSHs(pattern);
	152	XSRETURN(1);
	153	}
	154	} else {
	155	/* It ain't a regexp folks */
	156	if ( GIMME_V == G_ARRAY ) {
	157	/* return the empty list */
	158	XSRETURN_UNDEF;
	159	} else {
	160	/* Because of the (?:..) wrapping involved in a
	161	stringified pattern it is impossible to get a
	162	result for a real regexp that would evaluate to
	163	false. Therefore we can return PL_sv_no to signify
	164	that the object is not a regex, this means that one
	165	can say
	166
	167	if (regex($might_be_a_regex) eq '(?:foo)') { }
	168
	169	and not worry about undefined values.
	170	*/
	171	XSRETURN_NO;
	172	}
	173	}
	174	/* NOT-REACHED */
256ddcd0	175	}
	176
	177
	178	void
	179	regmust(sv)
	180	SV * sv
	181	PROTOTYPE: $
	182	PREINIT:
44a2ac75	183	regexp *re;
256ddcd0	184	PPCODE:
256ddcd0	185	{
44a2ac75	186	if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
256ddcd0	187	{
	188	SV *an = &PL_sv_no;
	189	SV *fl = &PL_sv_no;
256ddcd0	190	if (re->anchored_substr) {
	191	an = newSVsv(re->anchored_substr);
	192	} else if (re->anchored_utf8) {
	193	an = newSVsv(re->anchored_utf8);
	194	}
	195	if (re->float_substr) {
	196	fl = newSVsv(re->float_substr);
	197	} else if (re->float_utf8) {
	198	fl = newSVsv(re->float_utf8);
	199	}
	200	XPUSHs(an);
	201	XPUSHs(fl);
	202	XSRETURN(2);
	203	}
	204	XSRETURN_UNDEF;
	205	}
44a2ac75	206
	207	void
	208	regname(sv, qr = NULL, all = NULL)
	209	SV * sv
	210	SV * qr
	211	SV * all
	212	PROTOTYPE: ;$$$
	213	PREINIT:
	214	regexp *re = NULL;
	215	SV *bufs = NULL;
	216	PPCODE:
	217	{
	218	re = get_re_arg( aTHX_ qr, 1, NULL);
	219	if (SvPOK(sv) && re && re->paren_names) {
93b32b6d	220	bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
44a2ac75	221	if (bufs) {
	222	if (all && SvTRUE(all))
	223	XPUSHs(newRV(bufs));
	224	else
	225	XPUSHs(SvREFCNT_inc(bufs));
	226	XSRETURN(1);
	227	}
	228	}
	229	XSRETURN_UNDEF;
	230	}
	231
	232	void
	233	regnames(sv = NULL, all = NULL)
	234	SV *sv
	235	SV *all
	236	PROTOTYPE: ;$$
	237	PREINIT:
	238	regexp *re = NULL;
	239	IV count = 0;
	240	PPCODE:
	241	{
	242	re = get_re_arg( aTHX_ sv, 1, NULL );
	243	if (re && re->paren_names) {
	244	HV *hv= re->paren_names;
	245	(void)hv_iterinit(hv);
	246	while (1) {
	247	HE *temphe = hv_iternext_flags(hv,0);
	248	if (temphe) {
	249	IV i;
	250	IV parno = 0;
	251	SV* sv_dat = HeVAL(temphe);
	252	I32 nums = (I32)SvPVX(sv_dat);
	253	for ( i = 0; i < SvIVX(sv_dat); i++ ) {
	254	if ((I32)(re->lastcloseparen) >= nums[i] &&
	255	re->startp[nums[i]] != -1 &&
	256	re->endp[nums[i]] != -1)
	257	{
	258	parno = nums[i];
	259	break;
	260	}
	261	}
	262	if (parno \|\| (all && SvTRUE(all))) {
	263	STRLEN len;
	264	char *pv = HePV(temphe, len);
	265	if ( GIMME_V == G_ARRAY )
	266	XPUSHs(newSVpvn(pv,len));
	267	count++;
	268	}
	269	} else {
	270	break;
	271	}
	272	}
	273	}
	274	if ( GIMME_V == G_ARRAY )
	275	XSRETURN(count);
	276	else
	277	XSRETURN_UNDEF;
	278	}
	279
	280	void
	281	regnames_iterinit(sv = NULL)
	282	SV * sv
	283	PROTOTYPE: ;$
	284	PREINIT:
285	regexp *re = NULL;
286	PPCODE:
287	{
288	re = get_re_arg( aTHX_ sv, 1, NULL );
289	if (re && re->paren_names) {
290	(void)hv_iterinit(re->paren_names);
291	XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
292	} else {
293	XSRETURN_UNDEF;
294	}
295	}
296
297	void
298	regnames_iternext(sv = NULL, all = NULL)
299	SV *sv
300	SV *all
301	PROTOTYPE: ;$$
302	PREINIT:
303	regexp *re;
304	PPCODE:
305	{
306	re = get_re_arg( aTHX_ sv, 1, NULL );
307	if (re && re->paren_names) {
308	HV *hv= re->paren_names;
309	while (1) {
310	HE *temphe = hv_iternext_flags(hv,0);
311	if (temphe) {
312	IV i;
313	IV parno = 0;
314	SV* sv_dat = HeVAL(temphe);
315	I32 nums = (I32)SvPVX(sv_dat);
316	for ( i = 0; i < SvIVX(sv_dat); i++ ) {
317	if ((I32)(re->lastcloseparen) >= nums[i] &&
318	re->startp[nums[i]] != -1 &&
319	re->endp[nums[i]] != -1)
320	{
321	parno = nums[i];
322	break;
323	}
324	}
325	if (parno \|\| (all && SvTRUE(all))) {
326	STRLEN len;
327	char *pv = HePV(temphe, len);
328	XPUSHs(newSVpvn(pv,len));
329	XSRETURN(1);
330	}
331	} else {
332	break;
333	}
334	}
335	}
336	XSRETURN_UNDEF;
337	}
338
339	void
340	regnames_count(sv = NULL)
341	SV * sv
342	PROTOTYPE: ;$
343	PREINIT:
344	regexp *re = NULL;
345	PPCODE:
346	{
347	re = get_re_arg( aTHX_ sv, 1, NULL );
348	if (re && re->paren_names) {
349	XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
350	} else {
351	XSRETURN_UNDEF;
352	}
353	}