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                 if (!word) {
 129                     word = newSVpvs("");
 130                     if (is_utf8) SvUTF8_on(word);
 131                 }
 132                 if (piece) sv_catpvn(word, piece, s-piece);
 133                 piece = s+1;
 134                 while (++s <= patend)
 135                     if (*s == '\\') s++;
 136                     else if (*s == *(piece-1)) {
 137                         sv_catpvn(word, piece, s-piece);
 138                         piece = NULL;
 139                         found = TRUE;
 140                         break;
 141                     }
 142                 if (!found) { /* unmatched quote */
 143                     /* Give up on tokenisation and treat the whole string
 144                        as a single token, but with whitespace stripped. */
 145                     piece = pat;
 146                     while (isSPACE(*pat)) pat++;
 147                     while (isSPACE(*(patend-1))) patend--;
 148                     /* bsd_glob expects a trailing null, but we cannot mod-
 149                        ify the original */
 150                     if (patend < SvEND(patsv)) {
 151                         if (word) sv_setpvn(word, pat, patend-pat);
 152                         else
 153                             word = newSVpvn_flags(
 154                                 pat, patend-pat, SVf_UTF8*is_utf8
 155                             );
 156                         piece = NULL;
 157                     }
 158                     else {
 159                         if (word) SvREFCNT_dec(word), word=NULL;
 160                         piece = pat;
 161                         s = patend;
 162                     }
 163                     goto end_of_parsing;
 164                 }
 165                 break;
 166               }
 167             case '\\': if (!piece) piece = s; s++; break;
 168             default:
 169                 if (isSPACE(*s)) {
 170                     if (piece) {
 171                         if (!word) {
 172                             word = newSVpvn(piece,s-piece);
 173                             if (is_utf8) SvUTF8_on(word);
 174                         }
 175                         else sv_catpvn(word, piece, s-piece);
 176                     }
 177                     if (!word) break;
 178                     if (!patav) patav = (AV *)sv_2mortal((SV *)newAV());
 179                     av_push(patav, word);
 180                     word = NULL;
 181                     piece = NULL;
 182                 }
 183                 else if (!piece) piece = s;
 184                 break;
 185             }
 186         }
 187       end_of_parsing:
 188
 189         assert(!SvROK(entriesv));
 190         entries = (AV *)newSVrv(entriesv,NULL);
 191         sv_upgrade((SV *)entries, SVt_PVAV);
 192
 193         if (patav) {
 194             I32 items = AvFILLp(patav) + 1;
 195             SV **svp = AvARRAY(patav);
 196             while (items--) {
 197                 PUSHMARK(SP);
 198                 PUTBACK;
 199                 doglob(aTHX_ SvPVXx(*svp++), flags);
 200                 SPAGAIN;
 201                 {
 202                     dMARK;
 203                     dORIGMARK;
 204                     while (++MARK <= SP)
 205                         av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
 206                     SP = ORIGMARK;
 207                 }
 208             }
 209         }
 210         /* piece is set at this point if there is no trailing whitespace.
 211            It is the beginning of the last token or quote-delimited
 212            piece thereof.  word is set at this point if the last token has
 213            multiple quoted pieces. */
 214         if (piece || word) {
 215             if (word) {
 216                 if (piece) sv_catpvn(word, piece, s-piece);
 217                 piece = SvPVX(word);
 218             }
 219             PUSHMARK(SP);
 220             PUTBACK;
 221             doglob(aTHX_ piece, flags);
 222             if (word) SvREFCNT_dec(word);
 223             SPAGAIN;
 224             {
 225                 dMARK;
 226                 dORIGMARK;
 227                 while (++MARK <= SP)
 228                     av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
 229                 /* short-circuit here for a fairly common case */
 230                 if (!patav && gimme == G_ARRAY) goto return_list;
 231
 232                 SP = ORIGMARK;
 233             }
 234         }
 235     }
 236
 237     /* chuck it all out, quick or slow */
 238     assert(SvROK(entriesv));
 239     if (!entries) entries = (AV *)SvRV(entriesv);
 240     if (gimme == G_ARRAY) {
 241         Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
 242         SP += AvFILLp(entries)+1;
 243       return_list:
 244         hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
 245         /* No G_DISCARD here!  It will free the stack items. */
 246         hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
 247     }
 248     else {
 249         if (AvFILLp(entries) + 1) {
 250             sv_setiv(itersv, AvFILLp(entries) + 1);
 251             mPUSHs(av_shift(entries));
 252         }
 253         else {
 254             /* return undef for EOL */
 255             hv_delete(MY_CXT.x_GLOB_ITER, cxixpv, cxixlen, G_DISCARD);
 256             hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
 257             PUSHs(&PL_sv_undef);
 258         }
 259     }
 260     PUTBACK;
 261 }
 262
 263 MODULE = File::Glob             PACKAGE = File::Glob
 264
 265 int
 266 GLOB_ERROR()
 267     PREINIT:
 268         dMY_CXT;
 269     CODE:
 270         RETVAL = GLOB_ERROR;
 271     OUTPUT:
 272         RETVAL
 273
 274 void
 275 bsd_glob(pattern,...)
 276     char *pattern
 277 PREINIT:
 278     glob_t pglob;
 279     int i;
 280     int retval;
 281     int flags = 0;
 282     SV *tmp;
 283 PPCODE:
 284     {
 285         dMY_CXT;
 286
 287         /* allow for optional flags argument */
 288         if (items > 1) {
 289             flags = (int) SvIV(ST(1));
 290             /* remove unsupported flags */
 291             flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
 292         } else {
 293             flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 294         }
 295
 296         PUTBACK;
 297         doglob(aTHX_ pattern, flags);
 298         SPAGAIN;
 299     }
 300
 301 PROTOTYPES: DISABLE
 302 void
 303 csh_glob(...)
 304 PPCODE:
 305     /* For backward-compatibility with the original Perl function, we sim-
 306      * ply take the first two arguments, regardless of how many there are.
 307      */
 308     if (items >= 2) SP += 2;
 309     else {
 310         SP += items;
 311         XPUSHs(&PL_sv_undef);
 312         if (!items) XPUSHs(&PL_sv_undef);
 313     }
 314     PUTBACK;
 315     csh_glob(aTHX);
 316     SPAGAIN;
 317
 318 BOOT:
 319 {
 320 #ifndef PERL_EXTERNAL_GLOB
 321     /* Don’t do this at home! The globhook interface is highly volatile. */
 322     PL_globhook = csh_glob;
 323 #endif
 324 }
 325
 326 BOOT:
 327 {
 328     MY_CXT_INIT;
 329     {
 330         dMY_CXT;
 331         MY_CXT.x_GLOB_ITER = MY_CXT.x_GLOB_ENTRIES = NULL;
 332     }
 333 }
 334
 335 INCLUDE: const-xs.inc