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