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