This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Glob: silence some compiler warnings
[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 {
facf34ef
BF
12#ifdef USE_ITHREADS
13 tTHX interp;
14#endif
89ca4ac7 15 int x_GLOB_ERROR;
1bb8785a 16 HV * x_GLOB_ENTRIES;
d2f13afb 17 Perl_ophook_t x_GLOB_OLD_OPHOOK;
89ca4ac7
JH
18} my_cxt_t;
19
20START_MY_CXT
21
22#define GLOB_ERROR (MY_CXT.x_GLOB_ERROR)
72b16652 23
1cb0fb50 24#include "const-c.inc"
72b16652
GS
25
26#ifdef WIN32
27#define errfunc NULL
28#else
f681a178 29static int
72b16652 30errfunc(const char *foo, int bar) {
c33e8be1 31 PERL_UNUSED_ARG(foo);
5f18268b 32 return !(bar == EACCES || bar == ENOENT || bar == ENOTDIR);
72b16652
GS
33}
34#endif
35
1bb8785a
FC
36static void
37doglob(pTHX_ const char *pattern, int flags)
38{
39 dSP;
40 glob_t pglob;
41 int i;
42 int retval;
43 SV *tmp;
44 {
45 dMY_CXT;
46
47 /* call glob */
48 memset(&pglob, 0, sizeof(glob_t));
49 retval = bsd_glob(pattern, flags, errfunc, &pglob);
50 GLOB_ERROR = retval;
51
52 /* return any matches found */
53 EXTEND(sp, pglob.gl_pathc);
54 for (i = 0; i < pglob.gl_pathc; i++) {
55 /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
56 tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
57 SVs_TEMP);
58 TAINT;
59 SvTAINT(tmp);
60 PUSHs(tmp);
61 }
62 PUTBACK;
63
64 bsd_globfree(&pglob);
65 }
66}
67
1bb8785a 68static void
ace0afd9 69iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8))
1bb8785a
FC
70{
71 dSP;
72 dMY_CXT;
73
c58b680b
FC
74 const char * const cxixpv = (char *)&PL_op;
75 STRLEN const cxixlen = sizeof(OP *);
88b04955 76 AV *entries;
3ab888cf 77 U32 const gimme = GIMME_V;
1bb8785a 78 SV *patsv = POPs;
88b04955 79 bool on_stack = FALSE;
1bb8785a 80
1bb8785a 81 if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV();
1d6dcc39 82 entries = (AV *)*(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1));
1bb8785a
FC
83
84 /* if we're just beginning, do it all first */
1d6dcc39 85 if (SvTYPE(entries) != SVt_PVAV) {
ace0afd9
TC
86 const char *pat;
87 STRLEN len;
88 bool is_utf8;
89
90 /* glob without args defaults to $_ */
91 SvGETMAGIC(patsv);
92 if (
93 !SvOK(patsv)
94 && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
95 ) {
96 pat = "";
97 len = 0;
98 is_utf8 = 0;
99 }
100 else {
101 pat = SvPV_nomg(patsv,len);
102 is_utf8 = !!SvUTF8(patsv);
103 }
104
105 if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob")) {
106 if (gimme != G_ARRAY)
107 PUSHs(&PL_sv_undef);
108 PUTBACK;
109 return;
110 }
111
88b04955 112 PUTBACK;
ace0afd9 113 on_stack = globber(aTHX_ entries, pat, len, is_utf8);
88b04955
FC
114 SPAGAIN;
115 }
116
117 /* chuck it all out, quick or slow */
88b04955
FC
118 if (gimme == G_ARRAY) {
119 if (!on_stack) {
a6636b43 120 EXTEND(SP, AvFILLp(entries)+1);
88b04955
FC
121 Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
122 SP += AvFILLp(entries)+1;
123 }
88b04955
FC
124 /* No G_DISCARD here! It will free the stack items. */
125 hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
126 }
127 else {
128 if (AvFILLp(entries) + 1) {
88b04955
FC
129 mPUSHs(av_shift(entries));
130 }
131 else {
132 /* return undef for EOL */
88b04955
FC
133 hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
134 PUSHs(&PL_sv_undef);
135 }
136 }
137 PUTBACK;
138}
139
7a26772a
FC
140/* returns true if the items are on the stack already, but only in
141 list context */
88b04955 142static bool
ace0afd9 143csh_glob(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8)
88b04955
FC
144{
145 dSP;
1bb8785a
FC
146 AV *patav = NULL;
147 const char *patend;
88b04955 148 const char *s = NULL;
1bb8785a
FC
149 const char *piece = NULL;
150 SV *word = NULL;
151 int const flags =
152 (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
88b04955 153 U32 const gimme = GIMME_V;
1bb8785a 154
1bb8785a
FC
155 patend = pat + len;
156
41188aa0
TC
157 assert(SvTYPE(entries) != SVt_PVAV);
158 sv_upgrade((SV *)entries, SVt_PVAV);
159
1bb8785a 160 /* extract patterns */
1bb8785a
FC
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 */
ace0afd9 197 if (patend < pat + len) {
1bb8785a
FC
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
1bb8785a
FC
249 if (patav) {
250 I32 items = AvFILLp(patav) + 1;
251 SV **svp = AvARRAY(patav);
252 while (items--) {
253 PUSHMARK(SP);
254 PUTBACK;
255 doglob(aTHX_ SvPVXx(*svp++), flags);
256 SPAGAIN;
257 {
258 dMARK;
259 dORIGMARK;
260 while (++MARK <= SP)
261 av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
262 SP = ORIGMARK;
263 }
264 }
265 }
266 /* piece is set at this point if there is no trailing whitespace.
267 It is the beginning of the last token or quote-delimited
268 piece thereof. word is set at this point if the last token has
269 multiple quoted pieces. */
270 if (piece || word) {
271 if (word) {
272 if (piece) sv_catpvn(word, piece, s-piece);
273 piece = SvPVX(word);
274 }
275 PUSHMARK(SP);
276 PUTBACK;
277 doglob(aTHX_ piece, flags);
278 if (word) SvREFCNT_dec(word);
279 SPAGAIN;
280 {
281 dMARK;
282 dORIGMARK;
1bb8785a 283 /* short-circuit here for a fairly common case */
88b04955 284 if (!patav && gimme == G_ARRAY) { PUTBACK; return TRUE; }
c0d74586
FC
285 while (++MARK <= SP)
286 av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
1bb8785a
FC
287
288 SP = ORIGMARK;
289 }
290 }
88b04955
FC
291 PUTBACK;
292 return FALSE;
293}
1bb8785a 294
88b04955
FC
295static void
296csh_glob_iter(pTHX)
297{
298 iterate(aTHX_ csh_glob);
1bb8785a
FC
299}
300
f4cbf990
FC
301/* wrapper around doglob that can be passed to the iterator */
302static bool
ace0afd9 303doglob_iter_wrapper(pTHX_ AV *entries, const char *pattern, STRLEN len, bool is_utf8)
f4cbf990
FC
304{
305 dSP;
f4cbf990
FC
306 int const flags =
307 (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
f4cbf990 308
f4cbf990
FC
309 PUSHMARK(SP);
310 PUTBACK;
311 doglob(aTHX_ pattern, flags);
312 SPAGAIN;
313 {
314 dMARK;
315 dORIGMARK;
316 if (GIMME_V == G_ARRAY) { PUTBACK; return TRUE; }
f4cbf990
FC
317 sv_upgrade((SV *)entries, SVt_PVAV);
318 while (++MARK <= SP)
319 av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
320 SP = ORIGMARK;
321 }
322 return FALSE;
323}
324
11ddfebc
FC
325static void
326glob_ophook(pTHX_ OP *o)
327{
b8bafbdc
FC
328 if (PL_dirty) return;
329 {
11ddfebc
FC
330 dMY_CXT;
331 if (MY_CXT.x_GLOB_ENTRIES
332 && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB))
333 hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *),
334 G_DISCARD);
d2f13afb 335 if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o);
b8bafbdc 336 }
11ddfebc
FC
337}
338
72b16652
GS
339MODULE = File::Glob PACKAGE = File::Glob
340
b84cd0b1
NC
341int
342GLOB_ERROR()
343 PREINIT:
344 dMY_CXT;
345 CODE:
346 RETVAL = GLOB_ERROR;
347 OUTPUT:
348 RETVAL
349
72b16652 350void
ace0afd9
TC
351bsd_glob(pattern_sv,...)
352 SV *pattern_sv
72b16652 353PREINIT:
72b16652 354 int flags = 0;
ace0afd9
TC
355 char *pattern;
356 STRLEN len;
72b16652
GS
357PPCODE:
358 {
ace0afd9
TC
359 pattern = SvPV(pattern_sv, len);
360 if (!IS_SAFE_SYSCALL(pattern, len, "pattern", "bsd_glob"))
361 XSRETURN(0);
72b16652
GS
362 /* allow for optional flags argument */
363 if (items > 1) {
364 flags = (int) SvIV(ST(1));
3c97495f
CB
365 /* remove unsupported flags */
366 flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
960ddb65 367 } else {
28cd8e1d 368 flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
72b16652 369 }
1bb8785a
FC
370
371 PUTBACK;
372 doglob(aTHX_ pattern, flags);
373 SPAGAIN;
374 }
72b16652 375
1bb8785a
FC
376PROTOTYPES: DISABLE
377void
378csh_glob(...)
379PPCODE:
380 /* For backward-compatibility with the original Perl function, we sim-
f01818e2 381 * ply take the first argument, regardless of how many there are.
1bb8785a 382 */
f01818e2 383 if (items) SP ++;
1bb8785a 384 else {
1bb8785a 385 XPUSHs(&PL_sv_undef);
72b16652 386 }
1bb8785a 387 PUTBACK;
88b04955 388 csh_glob_iter(aTHX);
1bb8785a 389 SPAGAIN;
72b16652 390
f4cbf990
FC
391void
392bsd_glob_override(...)
393PPCODE:
f01818e2 394 if (items) SP ++;
f4cbf990 395 else {
f4cbf990 396 XPUSHs(&PL_sv_undef);
f4cbf990
FC
397 }
398 PUTBACK;
399 iterate(aTHX_ doglob_iter_wrapper);
400 SPAGAIN;
401
facf34ef
BF
402#ifdef USE_ITHREADS
403
404void
405CLONE(...)
406INIT:
407 HV *glob_entries_clone = NULL;
408CODE:
409 PERL_UNUSED_ARG(items);
410 {
411 dMY_CXT;
412 if ( MY_CXT.x_GLOB_ENTRIES ) {
413 CLONE_PARAMS param;
414 param.stashes = NULL;
415 param.flags = 0;
416 param.proto_perl = MY_CXT.interp;
417
418 glob_entries_clone = MUTABLE_HV(sv_dup_inc((SV*)MY_CXT.x_GLOB_ENTRIES, &param));
419 }
420 }
421 {
422 MY_CXT_CLONE;
423 MY_CXT.x_GLOB_ENTRIES = glob_entries_clone;
424 MY_CXT.interp = aTHX;
425 }
426
427#endif
428
28cd8e1d
NC
429BOOT:
430{
d67594ff 431#ifndef PERL_EXTERNAL_GLOB
e1fa07e3 432 /* Don't do this at home! The globhook interface is highly volatile. */
88b04955 433 PL_globhook = csh_glob_iter;
d67594ff 434#endif
bcd258b8 435}
28cd8e1d 436
bcd258b8
NC
437BOOT:
438{
28cd8e1d 439 MY_CXT_INIT;
1bb8785a
FC
440 {
441 dMY_CXT;
6a606603 442 MY_CXT.x_GLOB_ENTRIES = NULL;
d2f13afb 443 MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook;
facf34ef
BF
444#ifdef USE_ITHREADS
445 MY_CXT.interp = aTHX;
446#endif
d2f13afb 447 PL_opfreehook = glob_ophook;
1bb8785a 448 }
28cd8e1d
NC
449}
450
1cb0fb50 451INCLUDE: const-xs.inc