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