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