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