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