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 #ifdef USE_ITHREADS
  13     tTHX interp;
  14 #endif
  15     int         x_GLOB_ERROR;
  16     HV *        x_GLOB_ENTRIES;
  17     Perl_ophook_t       x_GLOB_OLD_OPHOOK;
  18 } my_cxt_t;
  19
  20 START_MY_CXT
  21
  22 #define GLOB_ERROR      (MY_CXT.x_GLOB_ERROR)
  23
  24 #include "const-c.inc"
  25
  26 #ifdef WIN32
  27 #define errfunc         NULL
  28 #else
  29 static int
  30 errfunc(const char *foo, int bar) {
  31   PERL_UNUSED_ARG(foo);
  32   return !(bar == EACCES || bar == ENOENT || bar == ENOTDIR);
  33 }
  34 #endif
  35
  36 static void
  37 doglob(pTHX_ const char *pattern, int flags)
  38 {
  39     dSP;
  40     glob_t pglob;
  41     int i;
  42     int retval;
  43     SV *tmp;
  44     {
  45         dMY_CXT;
  46
  47         /* call glob */
  48         memset(&pglob, 0, sizeof(glob_t));
  49         retval = bsd_glob(pattern, flags, errfunc, &pglob);
  50         GLOB_ERROR = retval;
  51
  52         /* return any matches found */
  53         EXTEND(sp, pglob.gl_pathc);
  54         for (i = 0; i < pglob.gl_pathc; i++) {
  55             /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
  56             tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
  57                                  SVs_TEMP);
  58             TAINT;
  59             SvTAINT(tmp);
  60             PUSHs(tmp);
  61         }
  62         PUTBACK;
  63
  64         bsd_globfree(&pglob);
  65     }
  66 }
  67
  68 static void
  69 iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8))
  70 {
  71     dSP;
  72     dMY_CXT;
  73
  74     const char * const cxixpv = (char *)&PL_op;
  75     STRLEN const cxixlen = sizeof(OP *);
  76     AV *entries;
  77     U32 const gimme = GIMME_V;
  78     SV *patsv = POPs;
  79     bool on_stack = FALSE;
  80
  81     if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV();
  82     entries = (AV *)*(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1));
  83
  84     /* if we're just beginning, do it all first */
  85     if (SvTYPE(entries) != SVt_PVAV) {
  86         const char *pat;
  87         STRLEN len;
  88         bool is_utf8;
  89
  90         /* glob without args defaults to $_ */
  91         SvGETMAGIC(patsv);
  92         if (
  93             !SvOK(patsv)
  94               && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
  95             ) {
  96             pat = "";
  97             len = 0;
  98             is_utf8 = 0;
  99         }
 100         else {
 101             pat = SvPV_nomg(patsv,len);
 102             is_utf8 = !!SvUTF8(patsv);
 103         }
 104
 105         if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob")) {
 106             if (gimme != G_ARRAY)
 107                 PUSHs(&PL_sv_undef);
 108             PUTBACK;
 109             return;
 110         }
 111
 112         PUTBACK;
 113         on_stack = globber(aTHX_ entries, pat, len, is_utf8);
 114         SPAGAIN;
 115     }
 116
 117     /* chuck it all out, quick or slow */
 118     if (gimme == G_ARRAY) {
 119         if (!on_stack) {
 120             EXTEND(SP, AvFILLp(entries)+1);
 121             Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
 122             SP += AvFILLp(entries)+1;
 123         }
 124         /* No G_DISCARD here!  It will free the stack items. */
 125         hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
 126     }
 127     else {
 128         if (AvFILLp(entries) + 1) {
 129             mPUSHs(av_shift(entries));
 130         }
 131         else {
 132             /* return undef for EOL */
 133             hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
 134             PUSHs(&PL_sv_undef);
 135         }
 136     }
 137     PUTBACK;
 138 }
 139
 140 /* returns true if the items are on the stack already, but only in
 141    list context */
 142 static bool
 143 csh_glob(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8)
 144 {
 145         dSP;
 146         AV *patav = NULL;
 147         const char *patend;
 148         const char *s = NULL;
 149         const char *piece = NULL;
 150         SV *word = NULL;
 151         int const flags =
 152             (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 153         U32 const gimme = GIMME_V;
 154
 155         patend = pat + len;
 156
 157         assert(SvTYPE(entries) != SVt_PVAV);
 158         sv_upgrade((SV *)entries, SVt_PVAV);
 159
 160         /* extract patterns */
 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 < pat + len) {
 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         if (patav) {
 250             I32 items = AvFILLp(patav) + 1;
 251             SV **svp = AvARRAY(patav);
 252             while (items--) {
 253                 PUSHMARK(SP);
 254                 PUTBACK;
 255                 doglob(aTHX_ SvPVXx(*svp++), flags);
 256                 SPAGAIN;
 257                 {
 258                     dMARK;
 259                     dORIGMARK;
 260                     while (++MARK <= SP)
 261                         av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
 262                     SP = ORIGMARK;
 263                 }
 264             }
 265         }
 266         /* piece is set at this point if there is no trailing whitespace.
 267            It is the beginning of the last token or quote-delimited
 268            piece thereof.  word is set at this point if the last token has
 269            multiple quoted pieces. */
 270         if (piece || word) {
 271             if (word) {
 272                 if (piece) sv_catpvn(word, piece, s-piece);
 273                 piece = SvPVX(word);
 274             }
 275             PUSHMARK(SP);
 276             PUTBACK;
 277             doglob(aTHX_ piece, flags);
 278             if (word) SvREFCNT_dec(word);
 279             SPAGAIN;
 280             {
 281                 dMARK;
 282                 dORIGMARK;
 283                 /* short-circuit here for a fairly common case */
 284                 if (!patav && gimme == G_ARRAY) { PUTBACK; return TRUE; }
 285                 while (++MARK <= SP)
 286                     av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
 287
 288                 SP = ORIGMARK;
 289             }
 290         }
 291         PUTBACK;
 292         return FALSE;
 293 }
 294
 295 static void
 296 csh_glob_iter(pTHX)
 297 {
 298     iterate(aTHX_ csh_glob);
 299 }
 300
 301 /* wrapper around doglob that can be passed to the iterator */
 302 static bool
 303 doglob_iter_wrapper(pTHX_ AV *entries, const char *pattern, STRLEN len, bool is_utf8)
 304 {
 305     dSP;
 306     int const flags =
 307             (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 308
 309     PUSHMARK(SP);
 310     PUTBACK;
 311     doglob(aTHX_ pattern, flags);
 312     SPAGAIN;
 313     {
 314         dMARK;
 315         dORIGMARK;
 316         if (GIMME_V == G_ARRAY) { PUTBACK; return TRUE; }
 317         sv_upgrade((SV *)entries, SVt_PVAV);
 318         while (++MARK <= SP)
 319             av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
 320         SP = ORIGMARK;
 321     }
 322     return FALSE;
 323 }
 324
 325 static void
 326 glob_ophook(pTHX_ OP *o)
 327 {
 328   if (PL_dirty) return;
 329   {
 330     dMY_CXT;
 331     if (MY_CXT.x_GLOB_ENTRIES
 332      && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB))
 333         hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *),
 334                   G_DISCARD);
 335     if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o);
 336   }
 337 }
 338
 339 MODULE = File::Glob             PACKAGE = File::Glob
 340
 341 int
 342 GLOB_ERROR()
 343     PREINIT:
 344         dMY_CXT;
 345     CODE:
 346         RETVAL = GLOB_ERROR;
 347     OUTPUT:
 348         RETVAL
 349
 350 void
 351 bsd_glob(pattern_sv,...)
 352     SV *pattern_sv
 353 PREINIT:
 354     int flags = 0;
 355     char *pattern;
 356     STRLEN len;
 357 PPCODE:
 358     {
 359         pattern = SvPV(pattern_sv, len);
 360         if (!IS_SAFE_SYSCALL(pattern, len, "pattern", "bsd_glob"))
 361             XSRETURN(0);
 362         /* allow for optional flags argument */
 363         if (items > 1) {
 364             flags = (int) SvIV(ST(1));
 365             /* remove unsupported flags */
 366             flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
 367         } else {
 368             flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 369         }
 370
 371         PUTBACK;
 372         doglob(aTHX_ pattern, flags);
 373         SPAGAIN;
 374     }
 375
 376 PROTOTYPES: DISABLE
 377 void
 378 csh_glob(...)
 379 PPCODE:
 380     /* For backward-compatibility with the original Perl function, we sim-
 381      * ply take the first argument, regardless of how many there are.
 382      */
 383     if (items) SP ++;
 384     else {
 385         XPUSHs(&PL_sv_undef);
 386     }
 387     PUTBACK;
 388     csh_glob_iter(aTHX);
 389     SPAGAIN;
 390
 391 void
 392 bsd_glob_override(...)
 393 PPCODE:
 394     if (items) SP ++;
 395     else {
 396         XPUSHs(&PL_sv_undef);
 397     }
 398     PUTBACK;
 399     iterate(aTHX_ doglob_iter_wrapper);
 400     SPAGAIN;
 401
 402 #ifdef USE_ITHREADS
 403
 404 void
 405 CLONE(...)
 406 INIT:
 407     HV *glob_entries_clone = NULL;
 408 CODE:
 409     PERL_UNUSED_ARG(items);
 410     {
 411         dMY_CXT;
 412         if ( MY_CXT.x_GLOB_ENTRIES ) {
 413             CLONE_PARAMS param;
 414             param.stashes    = NULL;
 415             param.flags      = 0;
 416             param.proto_perl = MY_CXT.interp;
 417
 418             glob_entries_clone = MUTABLE_HV(sv_dup_inc((SV*)MY_CXT.x_GLOB_ENTRIES, &param));
 419         }
 420     }
 421     {
 422         MY_CXT_CLONE;
 423         MY_CXT.x_GLOB_ENTRIES = glob_entries_clone;
 424         MY_CXT.interp = aTHX;
 425     }
 426
 427 #endif
 428
 429 BOOT:
 430 {
 431 #ifndef PERL_EXTERNAL_GLOB
 432     /* Don't do this at home! The globhook interface is highly volatile. */
 433     PL_globhook = csh_glob_iter;
 434 #endif
 435 }
 436
 437 BOOT:
 438 {
 439     MY_CXT_INIT;
 440     {
 441         dMY_CXT;
 442         MY_CXT.x_GLOB_ENTRIES = NULL;
 443         MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook;
 444 #ifdef USE_ITHREADS
 445         MY_CXT.interp = aTHX;
 446 #endif
 447         PL_opfreehook = glob_ophook;
 448     }
 449 }
 450
 451 INCLUDE: const-xs.inc