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