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