This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6189b0fa7aedef7136810d79f7028154a1277b17
[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, SV *patsv))
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         PUTBACK;
84         on_stack = globber(aTHX_ entries, patsv);
85         SPAGAIN;
86     }
87
88     /* chuck it all out, quick or slow */
89     if (gimme == G_ARRAY) {
90         if (!on_stack) {
91             EXTEND(SP, AvFILLp(entries)+1);
92             Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
93             SP += AvFILLp(entries)+1;
94         }
95         /* No G_DISCARD here!  It will free the stack items. */
96         hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
97     }
98     else {
99         if (AvFILLp(entries) + 1) {
100             mPUSHs(av_shift(entries));
101         }
102         else {
103             /* return undef for EOL */
104             hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
105             PUSHs(&PL_sv_undef);
106         }
107     }
108     PUTBACK;
109 }
110
111 /* returns true if the items are on the stack already, but only in
112    list context */
113 static bool
114 csh_glob(pTHX_ AV *entries, SV *patsv)
115 {
116         dSP;
117         const char *pat;
118         AV *patav = NULL;
119         const char *patend;
120         const char *s = NULL;
121         const char *piece = NULL;
122         SV *word = NULL;
123         int const flags =
124             (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
125         bool is_utf8;
126         STRLEN len;
127         U32 const gimme = GIMME_V;
128
129         /* glob without args defaults to $_ */
130         SvGETMAGIC(patsv);
131         if (
132             !SvOK(patsv)
133          && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
134         )
135              pat = "", len = 0, is_utf8 = 0;
136         else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
137         patend = pat + len;
138
139         assert(SvTYPE(entries) != SVt_PVAV);
140         sv_upgrade((SV *)entries, SVt_PVAV);
141
142         if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob"))
143             return FALSE;
144
145         /* extract patterns */
146         s = pat-1;
147         while (++s < patend) {
148             switch (*s) {
149             case '\'':
150             case '"' :
151               {
152                 bool found = FALSE;
153                 const char quote = *s;
154                 if (!word) {
155                     word = newSVpvs("");
156                     if (is_utf8) SvUTF8_on(word);
157                 }
158                 if (piece) sv_catpvn(word, piece, s-piece);
159                 piece = s+1;
160                 while (++s < patend)
161                     if (*s == '\\') {
162                         s++;
163                         /* If the backslash is here to escape a quote,
164                            obliterate it. */
165                         if (s < patend && *s == quote)
166                             sv_catpvn(word, piece, s-piece-1), piece = s;
167                     }
168                     else if (*s == quote) {
169                         sv_catpvn(word, piece, s-piece);
170                         piece = NULL;
171                         found = TRUE;
172                         break;
173                     }
174                 if (!found) { /* unmatched quote */
175                     /* Give up on tokenisation and treat the whole string
176                        as a single token, but with whitespace stripped. */
177                     piece = pat;
178                     while (isSPACE(*pat)) pat++;
179                     while (isSPACE(*(patend-1))) patend--;
180                     /* bsd_glob expects a trailing null, but we cannot mod-
181                        ify the original */
182                     if (patend < SvEND(patsv)) {
183                         if (word) sv_setpvn(word, pat, patend-pat);
184                         else
185                             word = newSVpvn_flags(
186                                 pat, patend-pat, SVf_UTF8*is_utf8
187                             );
188                         piece = NULL;
189                     }
190                     else {
191                         if (word) SvREFCNT_dec(word), word=NULL;
192                         piece = pat;
193                         s = patend;
194                     }
195                     goto end_of_parsing;
196                 }
197                 break;
198               }
199             case '\\':
200                 if (!piece) piece = s;
201                 s++;
202                 /* If the backslash is here to escape a quote,
203                    obliterate it. */
204                 if (s < patend && (*s == '"' || *s == '\'')) {
205                     if (!word) {
206                         word = newSVpvn(piece,s-piece-1);
207                         if (is_utf8) SvUTF8_on(word);
208                     }
209                     else sv_catpvn(word, piece, s-piece-1);
210                     piece = s;
211                 }
212                 break;
213             default:
214                 if (isSPACE(*s)) {
215                     if (piece) {
216                         if (!word) {
217                             word = newSVpvn(piece,s-piece);
218                             if (is_utf8) SvUTF8_on(word);
219                         }
220                         else sv_catpvn(word, piece, s-piece);
221                     }
222                     if (!word) break;
223                     if (!patav) patav = (AV *)sv_2mortal((SV *)newAV());
224                     av_push(patav, word);
225                     word = NULL;
226                     piece = NULL;
227                 }
228                 else if (!piece) piece = s;
229                 break;
230             }
231         }
232       end_of_parsing:
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 static void
320 glob_ophook(pTHX_ OP *o)
321 {
322   if (PL_dirty) return;
323   {
324     dMY_CXT;
325     if (MY_CXT.x_GLOB_ENTRIES
326      && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB))
327         hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *),
328                   G_DISCARD);
329     if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o);
330   }
331 }
332
333 MODULE = File::Glob             PACKAGE = File::Glob
334
335 int
336 GLOB_ERROR()
337     PREINIT:
338         dMY_CXT;
339     CODE:
340         RETVAL = GLOB_ERROR;
341     OUTPUT:
342         RETVAL
343
344 void
345 bsd_glob(pattern,...)
346     char *pattern
347 PREINIT:
348     int flags = 0;
349 PPCODE:
350     {
351         /* allow for optional flags argument */
352         if (items > 1) {
353             flags = (int) SvIV(ST(1));
354             /* remove unsupported flags */
355             flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
356         } else {
357             flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
358         }
359         
360         PUTBACK;
361         doglob(aTHX_ pattern, flags);
362         SPAGAIN;
363     }
364
365 PROTOTYPES: DISABLE
366 void
367 csh_glob(...)
368 PPCODE:
369     /* For backward-compatibility with the original Perl function, we sim-
370      * ply take the first argument, regardless of how many there are.
371      */
372     if (items) SP ++;
373     else {
374         XPUSHs(&PL_sv_undef);
375     }
376     PUTBACK;
377     csh_glob_iter(aTHX);
378     SPAGAIN;
379
380 void
381 bsd_glob_override(...)
382 PPCODE:
383     if (items) SP ++;
384     else {
385         XPUSHs(&PL_sv_undef);
386     }
387     PUTBACK;
388     iterate(aTHX_ doglob_iter_wrapper);
389     SPAGAIN;
390
391 BOOT:
392 {
393 #ifndef PERL_EXTERNAL_GLOB
394     /* Don't do this at home! The globhook interface is highly volatile. */
395     PL_globhook = csh_glob_iter;
396 #endif
397 }
398
399 BOOT:
400 {
401     MY_CXT_INIT;
402     {
403         dMY_CXT;
404         MY_CXT.x_GLOB_ENTRIES = NULL;
405         MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook;
406         PL_opfreehook = glob_ophook;
407     }  
408 }
409
410 INCLUDE: const-xs.inc