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