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