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