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