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