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 | |
67 | csh_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; | |
e1621fc9 | 128 | const char quote = *s; |
1bb8785a FC |
129 | if (!word) { |
130 | word = newSVpvs(""); | |
131 | if (is_utf8) SvUTF8_on(word); | |
132 | } | |
133 | if (piece) sv_catpvn(word, piece, s-piece); | |
134 | piece = s+1; | |
f89f9e93 | 135 | while (++s < patend) |
e1621fc9 FC |
136 | if (*s == '\\') { |
137 | s++; | |
138 | /* If the backslash is here to escape a quote, | |
139 | obliterate it. */ | |
140 | if (s < patend && *s == quote) | |
141 | sv_catpvn(word, piece, s-piece-1), piece = s; | |
142 | } | |
143 | else if (*s == quote) { | |
1bb8785a FC |
144 | sv_catpvn(word, piece, s-piece); |
145 | piece = NULL; | |
146 | found = TRUE; | |
147 | break; | |
148 | } | |
149 | if (!found) { /* unmatched quote */ | |
150 | /* Give up on tokenisation and treat the whole string | |
151 | as a single token, but with whitespace stripped. */ | |
152 | piece = pat; | |
153 | while (isSPACE(*pat)) pat++; | |
154 | while (isSPACE(*(patend-1))) patend--; | |
155 | /* bsd_glob expects a trailing null, but we cannot mod- | |
156 | ify the original */ | |
157 | if (patend < SvEND(patsv)) { | |
158 | if (word) sv_setpvn(word, pat, patend-pat); | |
159 | else | |
160 | word = newSVpvn_flags( | |
161 | pat, patend-pat, SVf_UTF8*is_utf8 | |
162 | ); | |
163 | piece = NULL; | |
164 | } | |
165 | else { | |
166 | if (word) SvREFCNT_dec(word), word=NULL; | |
167 | piece = pat; | |
168 | s = patend; | |
169 | } | |
170 | goto end_of_parsing; | |
171 | } | |
172 | break; | |
173 | } | |
e1621fc9 FC |
174 | case '\\': |
175 | if (!piece) piece = s; | |
176 | s++; | |
177 | /* If the backslash is here to escape a quote, | |
178 | obliterate it. */ | |
179 | if (s < patend && (*s == '"' || *s == '\'')) { | |
180 | if (!word) { | |
181 | word = newSVpvn(piece,s-piece-1); | |
182 | if (is_utf8) SvUTF8_on(word); | |
183 | } | |
184 | else sv_catpvn(word, piece, s-piece-1); | |
185 | piece = s; | |
186 | } | |
187 | break; | |
1bb8785a FC |
188 | default: |
189 | if (isSPACE(*s)) { | |
190 | if (piece) { | |
191 | if (!word) { | |
192 | word = newSVpvn(piece,s-piece); | |
193 | if (is_utf8) SvUTF8_on(word); | |
194 | } | |
195 | else sv_catpvn(word, piece, s-piece); | |
196 | } | |
197 | if (!word) break; | |
198 | if (!patav) patav = (AV *)sv_2mortal((SV *)newAV()); | |
199 | av_push(patav, word); | |
200 | word = NULL; | |
201 | piece = NULL; | |
202 | } | |
203 | else if (!piece) piece = s; | |
204 | break; | |
205 | } | |
206 | } | |
207 | end_of_parsing: | |
208 | ||
209 | assert(!SvROK(entriesv)); | |
210 | entries = (AV *)newSVrv(entriesv,NULL); | |
211 | sv_upgrade((SV *)entries, SVt_PVAV); | |
212 | ||
213 | if (patav) { | |
214 | I32 items = AvFILLp(patav) + 1; | |
215 | SV **svp = AvARRAY(patav); | |
216 | while (items--) { | |
217 | PUSHMARK(SP); | |
218 | PUTBACK; | |
219 | doglob(aTHX_ SvPVXx(*svp++), flags); | |
220 | SPAGAIN; | |
221 | { | |
222 | dMARK; | |
223 | dORIGMARK; | |
224 | while (++MARK <= SP) | |
225 | av_push(entries, SvREFCNT_inc_simple_NN(*MARK)); | |
226 | SP = ORIGMARK; | |
227 | } | |
228 | } | |
229 | } | |
230 | /* piece is set at this point if there is no trailing whitespace. | |
231 | It is the beginning of the last token or quote-delimited | |
232 | piece thereof. word is set at this point if the last token has | |
233 | multiple quoted pieces. */ | |
234 | if (piece || word) { | |
235 | if (word) { | |
236 | if (piece) sv_catpvn(word, piece, s-piece); | |
237 | piece = SvPVX(word); | |
238 | } | |
239 | PUSHMARK(SP); | |
240 | PUTBACK; | |
241 | doglob(aTHX_ piece, flags); | |
242 | if (word) SvREFCNT_dec(word); | |
243 | SPAGAIN; | |
244 | { | |
245 | dMARK; | |
246 | dORIGMARK; | |
1bb8785a FC |
247 | /* short-circuit here for a fairly common case */ |
248 | if (!patav && gimme == G_ARRAY) goto return_list; | |
c0d74586 FC |
249 | while (++MARK <= SP) |
250 | av_push(entries, SvREFCNT_inc_simple_NN(*MARK)); | |
1bb8785a FC |
251 | |
252 | SP = ORIGMARK; | |
253 | } | |
254 | } | |
255 | } | |
256 | ||
257 | /* chuck it all out, quick or slow */ | |
258 | assert(SvROK(entriesv)); | |
259 | if (!entries) entries = (AV *)SvRV(entriesv); | |
260 | if (gimme == G_ARRAY) { | |
261 | Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *); | |
262 | SP += AvFILLp(entries)+1; | |
263 | return_list: | |
264 | hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD); | |
265 | /* No G_DISCARD here! It will free the stack items. */ | |
266 | hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0); | |
267 | } | |
268 | else { | |
269 | if (AvFILLp(entries) + 1) { | |
270 | sv_setiv(itersv, AvFILLp(entries) + 1); | |
271 | mPUSHs(av_shift(entries)); | |
272 | } | |
273 | else { | |
274 | /* return undef for EOL */ | |
275 | hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD); | |
276 | hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD); | |
277 | PUSHs(&PL_sv_undef); | |
278 | } | |
279 | } | |
280 | PUTBACK; | |
281 | } | |
282 | ||
72b16652 GS |
283 | MODULE = File::Glob PACKAGE = File::Glob |
284 | ||
b84cd0b1 NC |
285 | int |
286 | GLOB_ERROR() | |
287 | PREINIT: | |
288 | dMY_CXT; | |
289 | CODE: | |
290 | RETVAL = GLOB_ERROR; | |
291 | OUTPUT: | |
292 | RETVAL | |
293 | ||
72b16652 | 294 | void |
960ddb65 | 295 | bsd_glob(pattern,...) |
72b16652 | 296 | char *pattern |
72b16652 GS |
297 | PREINIT: |
298 | glob_t pglob; | |
299 | int i; | |
300 | int retval; | |
301 | int flags = 0; | |
302 | SV *tmp; | |
303 | PPCODE: | |
304 | { | |
89ca4ac7 JH |
305 | dMY_CXT; |
306 | ||
72b16652 GS |
307 | /* allow for optional flags argument */ |
308 | if (items > 1) { | |
309 | flags = (int) SvIV(ST(1)); | |
3c97495f CB |
310 | /* remove unsupported flags */ |
311 | flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR); | |
960ddb65 | 312 | } else { |
28cd8e1d | 313 | flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD)); |
72b16652 | 314 | } |
1bb8785a FC |
315 | |
316 | PUTBACK; | |
317 | doglob(aTHX_ pattern, flags); | |
318 | SPAGAIN; | |
319 | } | |
72b16652 | 320 | |
1bb8785a FC |
321 | PROTOTYPES: DISABLE |
322 | void | |
323 | csh_glob(...) | |
324 | PPCODE: | |
325 | /* For backward-compatibility with the original Perl function, we sim- | |
326 | * ply take the first two arguments, regardless of how many there are. | |
327 | */ | |
328 | if (items >= 2) SP += 2; | |
329 | else { | |
330 | SP += items; | |
331 | XPUSHs(&PL_sv_undef); | |
332 | if (!items) XPUSHs(&PL_sv_undef); | |
72b16652 | 333 | } |
1bb8785a FC |
334 | PUTBACK; |
335 | csh_glob(aTHX); | |
336 | SPAGAIN; | |
72b16652 | 337 | |
28cd8e1d NC |
338 | BOOT: |
339 | { | |
d67594ff FC |
340 | #ifndef PERL_EXTERNAL_GLOB |
341 | /* Don’t do this at home! The globhook interface is highly volatile. */ | |
342 | PL_globhook = csh_glob; | |
343 | #endif | |
bcd258b8 | 344 | } |
28cd8e1d | 345 | |
bcd258b8 NC |
346 | BOOT: |
347 | { | |
28cd8e1d | 348 | MY_CXT_INIT; |
1bb8785a FC |
349 | { |
350 | dMY_CXT; | |
351 | MY_CXT.x_GLOB_ITER = MY_CXT.x_GLOB_ENTRIES = NULL; | |
352 | } | |
28cd8e1d NC |
353 | } |
354 | ||
1cb0fb50 | 355 | INCLUDE: const-xs.inc |