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