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