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