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