This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make csh_glob remove quote-escaping backslashes
[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;
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;
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
283MODULE = File::Glob PACKAGE = File::Glob
284
b84cd0b1
NC
285int
286GLOB_ERROR()
287 PREINIT:
288 dMY_CXT;
289 CODE:
290 RETVAL = GLOB_ERROR;
291 OUTPUT:
292 RETVAL
293
72b16652 294void
960ddb65 295bsd_glob(pattern,...)
72b16652 296 char *pattern
72b16652
GS
297PREINIT:
298 glob_t pglob;
299 int i;
300 int retval;
301 int flags = 0;
302 SV *tmp;
303PPCODE:
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
321PROTOTYPES: DISABLE
322void
323csh_glob(...)
324PPCODE:
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
338BOOT:
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
346BOOT:
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 355INCLUDE: const-xs.inc