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