[perl5.git] / ext / File-Glob / Glob.xs

#define PERL_NO_GET_CONTEXT

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "bsd_glob.h"

#define MY_CXT_KEY "File::Glob::_guts" XS_VERSION

typedef struct {
    int		x_GLOB_ERROR;
    HV *	x_GLOB_ITER;
    HV *	x_GLOB_ENTRIES;
} my_cxt_t;

START_MY_CXT

#define GLOB_ERROR	(MY_CXT.x_GLOB_ERROR)

#include "const-c.inc"

#ifdef WIN32
#define errfunc		NULL
#else
static int
errfunc(const char *foo, int bar) {
  PERL_UNUSED_ARG(foo);
  return !(bar == EACCES || bar == ENOENT || bar == ENOTDIR);
}
#endif

static void
doglob(pTHX_ const char *pattern, int flags)
{
    dSP;
    glob_t pglob;
    int i;
    int retval;
    SV *tmp;
    {
	dMY_CXT;

	/* call glob */
	memset(&pglob, 0, sizeof(glob_t));
	retval = bsd_glob(pattern, flags, errfunc, &pglob);
	GLOB_ERROR = retval;

	/* return any matches found */
	EXTEND(sp, pglob.gl_pathc);
	for (i = 0; i < pglob.gl_pathc; i++) {
	    /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
	    tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
				 SVs_TEMP);
	    TAINT;
	    SvTAINT(tmp);
	    PUSHs(tmp);
	}
	PUTBACK;

	bsd_globfree(&pglob);
    }
}

/* borrowed heavily from gsar's File::DosGlob, but translated into C */
static void
csh_glob(pTHX)
{
    dSP;
    dMY_CXT;

    SV *cxixsv = POPs;
    const char *cxixpv;
    STRLEN cxixlen;
    STRLEN len;
    const char *s = NULL;
    SV *itersv;
    SV *entriesv;
    AV *entries = NULL;
    U32 gimme = GIMME_V;
    SV *patsv = POPs;

    /* assume global context if not provided one */
    SvGETMAGIC(cxixsv);
    if (SvOK(cxixsv)) cxixpv = SvPV_nomg(cxixsv, cxixlen);
    else cxixpv = "_G_", cxixlen = 3;

    if (!MY_CXT.x_GLOB_ITER) MY_CXT.x_GLOB_ITER = newHV();
    itersv = *(hv_fetch(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, 1));
    if (!SvOK(itersv)) sv_setiv(itersv,0);

    if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV();
    entriesv = *(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1));

    /* if we're just beginning, do it all first */
    if (!SvIV(itersv)) {
	const char *pat;
	AV *patav = NULL;
	const char *patend;
	const char *piece = NULL;
	SV *word = NULL;
	int const flags =
	    (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
	bool is_utf8;

	/* glob without args defaults to $_ */
	SvGETMAGIC(patsv);
	if (
	    !SvOK(patsv)
	 && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
	)
	     pat = "", len = 0, is_utf8 = 0;
	else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
	patend = pat + len;

	/* extract patterns */
	/* XXX this is needed for compatibility with the csh
	 * implementation in Perl.  Need to support a flag
	 * to disable this behavior.
	 */
	s = pat-1;
	while (++s < patend) {
	    switch (*s) {
	    case '\'':
	    case '"' :
	      {
		bool found = FALSE;
		const char quote = *s;
		if (!word) {
		    word = newSVpvs("");
		    if (is_utf8) SvUTF8_on(word);
		}
		if (piece) sv_catpvn(word, piece, s-piece);
		piece = s+1;
		while (++s < patend)
		    if (*s == '\\') {
			s++;
			/* If the backslash is here to escape a quote,
			   obliterate it. */
			if (s < patend && *s == quote)
			    sv_catpvn(word, piece, s-piece-1), piece = s;
		    }
		    else if (*s == quote) {
			sv_catpvn(word, piece, s-piece);
			piece = NULL;
			found = TRUE;
			break;
		    }
		if (!found) { /* unmatched quote */
		    /* Give up on tokenisation and treat the whole string
		       as a single token, but with whitespace stripped. */
		    piece = pat;
		    while (isSPACE(*pat)) pat++;
		    while (isSPACE(*(patend-1))) patend--;
		    /* bsd_glob expects a trailing null, but we cannot mod-
		       ify the original */
		    if (patend < SvEND(patsv)) {
			if (word) sv_setpvn(word, pat, patend-pat);
			else
			    word = newSVpvn_flags(
				pat, patend-pat, SVf_UTF8*is_utf8
			    );
			piece = NULL;
		    }
		    else {
			if (word) SvREFCNT_dec(word), word=NULL;
			piece = pat;
			s = patend;
		    }
		    goto end_of_parsing;
		}
		break;
	      }
	    case '\\':
		if (!piece) piece = s;
		s++;
		/* If the backslash is here to escape a quote,
		   obliterate it. */
		if (s < patend && (*s == '"' || *s == '\'')) {
		    if (!word) {
			word = newSVpvn(piece,s-piece-1);
			if (is_utf8) SvUTF8_on(word);
		    }
		    else sv_catpvn(word, piece, s-piece-1);
		    piece = s;
		}
		break;
	    default:
		if (isSPACE(*s)) {
		    if (piece) {
			if (!word) {
			    word = newSVpvn(piece,s-piece);
			    if (is_utf8) SvUTF8_on(word);
			}
			else sv_catpvn(word, piece, s-piece);
		    }
		    if (!word) break;
		    if (!patav) patav = (AV *)sv_2mortal((SV *)newAV());
		    av_push(patav, word);
		    word = NULL;
		    piece = NULL;
		}
		else if (!piece) piece = s;
		break;
	    }
	}
      end_of_parsing:

	assert(!SvROK(entriesv));
	entries = (AV *)newSVrv(entriesv,NULL);
	sv_upgrade((SV *)entries, SVt_PVAV);
	
	if (patav) {
	    I32 items = AvFILLp(patav) + 1;
	    SV **svp = AvARRAY(patav);
	    while (items--) {
		PUSHMARK(SP);
		PUTBACK;
		doglob(aTHX_ SvPVXx(*svp++), flags);
		SPAGAIN;
		{
		    dMARK;
		    dORIGMARK;
		    while (++MARK <= SP)
			av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
		    SP = ORIGMARK;
		}
	    }
	}
	/* piece is set at this point if there is no trailing whitespace.
	   It is the beginning of the last token or quote-delimited
	   piece thereof.  word is set at this point if the last token has
	   multiple quoted pieces. */
	if (piece || word) {
	    if (word) {
		if (piece) sv_catpvn(word, piece, s-piece);
		piece = SvPVX(word);
	    }
	    PUSHMARK(SP);
	    PUTBACK;
	    doglob(aTHX_ piece, flags);
	    if (word) SvREFCNT_dec(word);
	    SPAGAIN;
	    {
		dMARK;
		dORIGMARK;
		/* short-circuit here for a fairly common case */
		if (!patav && gimme == G_ARRAY) goto return_list;
		while (++MARK <= SP)
		    av_push(entries, SvREFCNT_inc_simple_NN(*MARK));

		SP = ORIGMARK;
	    }
	}
    }

    /* chuck it all out, quick or slow */
    assert(SvROK(entriesv));
    if (!entries) entries = (AV *)SvRV(entriesv);
    if (gimme == G_ARRAY) {
	Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
	SP += AvFILLp(entries)+1;
      return_list:
	hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
	/* No G_DISCARD here!  It will free the stack items. */
	hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
    }
    else {
	if (AvFILLp(entries) + 1) {
	    sv_setiv(itersv, AvFILLp(entries) + 1);
	    mPUSHs(av_shift(entries));
	}
	else {
	    /* return undef for EOL */
	    hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
	    hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
	    PUSHs(&PL_sv_undef);
	}
    }
    PUTBACK;
}

MODULE = File::Glob		PACKAGE = File::Glob

int
GLOB_ERROR()
    PREINIT:
	dMY_CXT;
    CODE:
	RETVAL = GLOB_ERROR;
    OUTPUT:
	RETVAL

void
bsd_glob(pattern,...)
    char *pattern
PREINIT:
    glob_t pglob;
    int i;
    int retval;
    int flags = 0;
    SV *tmp;
PPCODE:
    {
	dMY_CXT;

	/* allow for optional flags argument */
	if (items > 1) {
	    flags = (int) SvIV(ST(1));
	    /* remove unsupported flags */
	    flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
	} else {
	    flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
	}
	
	PUTBACK;
	doglob(aTHX_ pattern, flags);
	SPAGAIN;
    }

PROTOTYPES: DISABLE
void
csh_glob(...)
PPCODE:
    /* For backward-compatibility with the original Perl function, we sim-
     * ply take the first two arguments, regardless of how many there are.
     */
    if (items >= 2) SP += 2;
    else {
	SP += items;
	XPUSHs(&PL_sv_undef);
	if (!items) XPUSHs(&PL_sv_undef);
    }
    PUTBACK;
    csh_glob(aTHX);
    SPAGAIN;

BOOT:
{
#ifndef PERL_EXTERNAL_GLOB
    /* Don’t do this at home! The globhook interface is highly volatile. */
    PL_globhook = csh_glob;
#endif
}

BOOT:
{
    MY_CXT_INIT;
    {
	dMY_CXT;
	MY_CXT.x_GLOB_ITER = MY_CXT.x_GLOB_ENTRIES = NULL;
    }  
}

INCLUDE: const-xs.inc
Commit	Line	Data
8e9c4baf NC	1	#define PERL_NO_GET_CONTEXT
8e9c4baf NC	2
72b16652 GS	3	#include "EXTERN.h"
	4	#include "perl.h"
	5	#include "XSUB.h"
	6
	7	#include "bsd_glob.h"
	8
df3728a2	9	#define MY_CXT_KEY "File::Glob::_guts" XS_VERSION
89ca4ac7 JH	10
	11	typedef struct {
	12	int x_GLOB_ERROR;
1bb8785a FC	13	HV * x_GLOB_ITER;
1bb8785a FC	14	HV * x_GLOB_ENTRIES;
89ca4ac7 JH	15	} my_cxt_t;
	16
	17	START_MY_CXT
	18
	19	#define GLOB_ERROR (MY_CXT.x_GLOB_ERROR)
72b16652	20
1cb0fb50	21	#include "const-c.inc"
72b16652 GS	22
	23	#ifdef WIN32
	24	#define errfunc NULL
	25	#else
f681a178	26	static int
72b16652	27	errfunc(const char *foo, int bar) {
c33e8be1	28	PERL_UNUSED_ARG(foo);
5f18268b	29	return !(bar == EACCES \|\| bar == ENOENT \|\| bar == ENOTDIR);
72b16652 GS	30	}
	31	#endif
	32
1bb8785a FC	33	static void
	34	doglob(pTHX_ const char *pattern, int flags)
	35	{
	36	dSP;
	37	glob_t pglob;
	38	int i;
	39	int retval;
	40	SV *tmp;
	41	{
	42	dMY_CXT;
	43
	44	/* call glob */
	45	memset(&pglob, 0, sizeof(glob_t));
	46	retval = bsd_glob(pattern, flags, errfunc, &pglob);
	47	GLOB_ERROR = retval;
	48
	49	/* return any matches found */
	50	EXTEND(sp, pglob.gl_pathc);
	51	for (i = 0; i < pglob.gl_pathc; i++) {
	52	/* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
	53	tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
	54	SVs_TEMP);
	55	TAINT;
	56	SvTAINT(tmp);
	57	PUSHs(tmp);
	58	}
	59	PUTBACK;
	60
	61	bsd_globfree(&pglob);
	62	}
	63	}
	64
	65	/* borrowed heavily from gsar's File::DosGlob, but translated into C */
	66	static void
	67	csh_glob(pTHX)
	68	{
	69	dSP;
	70	dMY_CXT;
	71
	72	SV *cxixsv = POPs;
	73	const char *cxixpv;
	74	STRLEN cxixlen;
	75	STRLEN len;
	76	const char *s = NULL;
	77	SV *itersv;
	78	SV *entriesv;
	79	AV *entries = NULL;
	80	U32 gimme = GIMME_V;
	81	SV *patsv = POPs;
	82
	83	/* assume global context if not provided one */
	84	SvGETMAGIC(cxixsv);
	85	if (SvOK(cxixsv)) cxixpv = SvPV_nomg(cxixsv, cxixlen);
	86	else cxixpv = "_G_", cxixlen = 3;
	87
	88	if (!MY_CXT.x_GLOB_ITER) MY_CXT.x_GLOB_ITER = newHV();
	89	itersv = *(hv_fetch(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, 1));
	90	if (!SvOK(itersv)) sv_setiv(itersv,0);
	91
	92	if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV();
	93	entriesv = *(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1));
	94
	95	/* if we're just beginning, do it all first */
	96	if (!SvIV(itersv)) {
97	const char *pat;
98	AV *patav = NULL;
99	const char *patend;
100	const char *piece = NULL;
101	SV *word = NULL;
102	int const flags =
103	(int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
104	bool is_utf8;
105
106	/* glob without args defaults to $_ */
107	SvGETMAGIC(patsv);
108	if (
109	!SvOK(patsv)
110	&& (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
111	)
112	pat = "", len = 0, is_utf8 = 0;
113	else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
114	patend = pat + len;
115
116	/* extract patterns */
117	/* XXX this is needed for compatibility with the csh
118	* implementation in Perl. Need to support a flag
119	* to disable this behavior.
120	*/
121	s = pat-1;
122	while (++s < patend) {
123	switch (*s) {
124	case '\'':
125	case '"' :
126	{
127	bool found = FALSE;
e1621fc9	128	const char quote = *s;
1bb8785a FC	129	if (!word) {
	130	word = newSVpvs("");
	131	if (is_utf8) SvUTF8_on(word);
	132	}
	133	if (piece) sv_catpvn(word, piece, s-piece);
	134	piece = s+1;
f89f9e93	135	while (++s < patend)
e1621fc9 FC	136	if (*s == '\\') {
	137	s++;
	138	/* If the backslash is here to escape a quote,
	139	obliterate it. */
	140	if (s < patend && *s == quote)
	141	sv_catpvn(word, piece, s-piece-1), piece = s;
	142	}
	143	else if (*s == quote) {
1bb8785a FC	144	sv_catpvn(word, piece, s-piece);
	145	piece = NULL;
	146	found = TRUE;
	147	break;
	148	}
	149	if (!found) { /* unmatched quote */
	150	/* Give up on tokenisation and treat the whole string
	151	as a single token, but with whitespace stripped. */
	152	piece = pat;
	153	while (isSPACE(*pat)) pat++;
	154	while (isSPACE(*(patend-1))) patend--;
	155	/* bsd_glob expects a trailing null, but we cannot mod-
	156	ify the original */
	157	if (patend < SvEND(patsv)) {
	158	if (word) sv_setpvn(word, pat, patend-pat);
	159	else
	160	word = newSVpvn_flags(
	161	pat, patend-pat, SVf_UTF8*is_utf8
	162	);
	163	piece = NULL;
	164	}
	165	else {
	166	if (word) SvREFCNT_dec(word), word=NULL;
	167	piece = pat;
	168	s = patend;
	169	}
	170	goto end_of_parsing;
	171	}
	172	break;
	173	}
e1621fc9 FC	174	case '\\':
	175	if (!piece) piece = s;
	176	s++;
	177	/* If the backslash is here to escape a quote,
	178	obliterate it. */
	179	if (s < patend && (s == '"' \|\| s == '\'')) {
	180	if (!word) {
	181	word = newSVpvn(piece,s-piece-1);
	182	if (is_utf8) SvUTF8_on(word);
	183	}
	184	else sv_catpvn(word, piece, s-piece-1);
	185	piece = s;
	186	}
	187	break;
1bb8785a FC	188	default:
	189	if (isSPACE(*s)) {
	190	if (piece) {
	191	if (!word) {
	192	word = newSVpvn(piece,s-piece);
	193	if (is_utf8) SvUTF8_on(word);
	194	}
	195	else sv_catpvn(word, piece, s-piece);
	196	}
	197	if (!word) break;
	198	if (!patav) patav = (AV )sv_2mortal((SV )newAV());
	199	av_push(patav, word);
	200	word = NULL;
	201	piece = NULL;
	202	}
	203	else if (!piece) piece = s;
	204	break;
	205	}
	206	}
	207	end_of_parsing:
	208
	209	assert(!SvROK(entriesv));
	210	entries = (AV *)newSVrv(entriesv,NULL);
	211	sv_upgrade((SV *)entries, SVt_PVAV);
	212
	213	if (patav) {
	214	I32 items = AvFILLp(patav) + 1;
	215	SV **svp = AvARRAY(patav);
	216	while (items--) {
	217	PUSHMARK(SP);
	218	PUTBACK;
	219	doglob(aTHX_ SvPVXx(*svp++), flags);
	220	SPAGAIN;
	221	{
	222	dMARK;
	223	dORIGMARK;
	224	while (++MARK <= SP)
	225	av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
	226	SP = ORIGMARK;
	227	}
	228	}
	229	}
	230	/* piece is set at this point if there is no trailing whitespace.
	231	It is the beginning of the last token or quote-delimited
	232	piece thereof. word is set at this point if the last token has
	233	multiple quoted pieces. */
	234	if (piece \|\| word) {
	235	if (word) {
	236	if (piece) sv_catpvn(word, piece, s-piece);
	237	piece = SvPVX(word);
	238	}
	239	PUSHMARK(SP);
	240	PUTBACK;
	241	doglob(aTHX_ piece, flags);
	242	if (word) SvREFCNT_dec(word);
	243	SPAGAIN;
	244	{
	245	dMARK;
	246	dORIGMARK;
1bb8785a FC	247	/* short-circuit here for a fairly common case */
1bb8785a FC	248	if (!patav && gimme == G_ARRAY) goto return_list;
c0d74586 FC	249	while (++MARK <= SP)
c0d74586 FC	250	av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
1bb8785a FC	251
	252	SP = ORIGMARK;
	253	}
	254	}
	255	}
	256
	257	/* chuck it all out, quick or slow */
	258	assert(SvROK(entriesv));
	259	if (!entries) entries = (AV *)SvRV(entriesv);
	260	if (gimme == G_ARRAY) {
	261	Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
	262	SP += AvFILLp(entries)+1;
	263	return_list:
	264	hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
	265	/* No G_DISCARD here! It will free the stack items. */
	266	hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
	267	}
	268	else {
	269	if (AvFILLp(entries) + 1) {
	270	sv_setiv(itersv, AvFILLp(entries) + 1);
	271	mPUSHs(av_shift(entries));
	272	}
	273	else {
	274	/* return undef for EOL */
	275	hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
	276	hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
	277	PUSHs(&PL_sv_undef);
	278	}
	279	}
	280	PUTBACK;
	281	}
	282
72b16652 GS	283	MODULE = File::Glob PACKAGE = File::Glob
72b16652 GS	284
b84cd0b1 NC	285	int
	286	GLOB_ERROR()
	287	PREINIT:
	288	dMY_CXT;
	289	CODE:
	290	RETVAL = GLOB_ERROR;
	291	OUTPUT:
	292	RETVAL
	293
72b16652	294	void
960ddb65	295	bsd_glob(pattern,...)
72b16652	296	char *pattern
72b16652 GS	297	PREINIT:
	298	glob_t pglob;
	299	int i;
	300	int retval;
	301	int flags = 0;
	302	SV *tmp;
	303	PPCODE:
	304	{
89ca4ac7 JH	305	dMY_CXT;
89ca4ac7 JH	306
72b16652 GS	307	/* allow for optional flags argument */
	308	if (items > 1) {
	309	flags = (int) SvIV(ST(1));
3c97495f CB	310	/* remove unsupported flags */
3c97495f CB	311	flags &= ~(GLOB_APPEND \| GLOB_DOOFFS \| GLOB_ALTDIRFUNC \| GLOB_MAGCHAR);
960ddb65	312	} else {
28cd8e1d	313	flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
72b16652	314	}
1bb8785a FC	315
	316	PUTBACK;
	317	doglob(aTHX_ pattern, flags);
	318	SPAGAIN;
	319	}
72b16652	320
1bb8785a FC	321	PROTOTYPES: DISABLE
	322	void
	323	csh_glob(...)
	324	PPCODE:
	325	/* For backward-compatibility with the original Perl function, we sim-
	326	* ply take the first two arguments, regardless of how many there are.
	327	*/
	328	if (items >= 2) SP += 2;
	329	else {
	330	SP += items;
	331	XPUSHs(&PL_sv_undef);
	332	if (!items) XPUSHs(&PL_sv_undef);
72b16652	333	}
1bb8785a FC	334	PUTBACK;
	335	csh_glob(aTHX);
	336	SPAGAIN;
72b16652	337
28cd8e1d NC	338	BOOT:
28cd8e1d NC	339	{
d67594ff FC	340	#ifndef PERL_EXTERNAL_GLOB
	341	/* Don’t do this at home! The globhook interface is highly volatile. */
	342	PL_globhook = csh_glob;
	343	#endif
bcd258b8	344	}
28cd8e1d	345
bcd258b8 NC	346	BOOT:
bcd258b8 NC	347	{
28cd8e1d	348	MY_CXT_INIT;
1bb8785a FC	349	{
	350	dMY_CXT;
	351	MY_CXT.x_GLOB_ITER = MY_CXT.x_GLOB_ENTRIES = NULL;
	352	}
28cd8e1d NC	353	}
28cd8e1d NC	354
1cb0fb50	355	INCLUDE: const-xs.inc