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