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