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     int flags = 0;
 336 PPCODE:
 337     {
 338         /* allow for optional flags argument */
 339         if (items > 1) {
 340             flags = (int) SvIV(ST(1));
 341             /* remove unsupported flags */
 342             flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
 343         } else {
 344             flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 345         }
 346
 347         PUTBACK;
 348         doglob(aTHX_ pattern, flags);
 349         SPAGAIN;
 350     }
 351
 352 PROTOTYPES: DISABLE
 353 void
 354 csh_glob(...)
 355 PPCODE:
 356     /* For backward-compatibility with the original Perl function, we sim-
 357      * ply take the first two arguments, regardless of how many there are.
 358      */
 359     if (items >= 2) SP += 2;
 360     else {
 361         SP += items;
 362         XPUSHs(&PL_sv_undef);
 363         if (!items) XPUSHs(&PL_sv_undef);
 364     }
 365     PUTBACK;
 366     csh_glob_iter(aTHX);
 367     SPAGAIN;
 368
 369 void
 370 bsd_glob_override(...)
 371 PPCODE:
 372     if (items >= 2) SP += 2;
 373     else {
 374         SP += items;
 375         XPUSHs(&PL_sv_undef);
 376         if (!items) XPUSHs(&PL_sv_undef);
 377     }
 378     PUTBACK;
 379     iterate(aTHX_ doglob_iter_wrapper);
 380     SPAGAIN;
 381
 382 BOOT:
 383 {
 384 #ifndef PERL_EXTERNAL_GLOB
 385     /* Don't do this at home! The globhook interface is highly volatile. */
 386     PL_globhook = csh_glob_iter;
 387 #endif
 388 }
 389
 390 BOOT:
 391 {
 392     MY_CXT_INIT;
 393     {
 394         dMY_CXT;
 395         MY_CXT.x_GLOB_ENTRIES = NULL;
 396     }
 397 }
 398
 399 INCLUDE: const-xs.inc