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