This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add :bsd_glob export tag to File::Glob [perl #96116]
authorFather Chrysostomos <sprout@cpan.org>
Sat, 29 Oct 2011 07:02:01 +0000 (00:02 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 29 Oct 2011 07:17:44 +0000 (00:17 -0700)
This is intended to replace the :glob export tag.  The problem with
:glob is that the glob export (File::Glob::glob) does not support ite-
ration, but tries to return a whole list each time; hence it causes
while(<*>) to loop endlessly, as it is repeatedly returning the last
file (scalar context).

Since there may be code relying on that, we cannot easily change it,
but we can supplant it.

Since bsd_glob is already documented as supporting spaces in patterns
(that match spaces in file names; i.e., that are not separators), this
commit adds a :bsd_glob export tag that only differs from :glob in
that the exported glob() function iterates in scalar context.

An imminent commit will add documentation.

ext/File-Glob/Glob.pm
ext/File-Glob/Glob.xs
ext/File-Glob/t/basic.t

index a665816..974625b 100644 (file)
@@ -29,10 +29,12 @@ use feature 'switch';
         GLOB_NOSPACE
         GLOB_QUOTE
         GLOB_TILDE
         GLOB_NOSPACE
         GLOB_QUOTE
         GLOB_TILDE
-        glob
         bsd_glob
         bsd_glob
+        glob
     ) ],
 );
     ) ],
 );
+$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
+pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob"
 
 @EXPORT_OK   = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
 
 
 @EXPORT_OK   = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
 
@@ -50,6 +52,9 @@ sub import {
                no warnings 'redefine';
                *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
            }
                no warnings 'redefine';
                *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
            }
+           if ($_ eq ':bsd_glob') {
+               no strict; *{caller."::glob"} = \&bsd_glob_override;
+           }
            $passthrough = 1;
        }
        $passthrough;
            $passthrough = 1;
        }
        $passthrough;
index 62e6ad4..b9b1006 100644 (file)
@@ -302,6 +302,41 @@ csh_glob_iter(pTHX)
     iterate(aTHX_ csh_glob);
 }
 
     iterate(aTHX_ csh_glob);
 }
 
+/* wrapper around doglob that can be passed to the iterator */
+static bool
+doglob_iter_wrapper(pTHX_ SV *entriesv, SV *patsv)
+{
+    dSP;
+    const char *pattern;
+    int const flags =
+           (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
+    AV *entries;
+
+    SvGETMAGIC(patsv);
+    if (
+           !SvOK(patsv)
+        && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
+    )
+        pattern = "";
+    else pattern = SvPV_nomg_nolen(patsv);
+
+    PUSHMARK(SP);
+    PUTBACK;
+    doglob(aTHX_ pattern, flags);
+    SPAGAIN;
+    {
+       dMARK;
+       dORIGMARK;
+       if (GIMME_V == G_ARRAY) { PUTBACK; return TRUE; }
+       entries = (AV *)newSVrv(entriesv,NULL);
+       sv_upgrade((SV *)entries, SVt_PVAV);
+       while (++MARK <= SP)
+           av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
+       SP = ORIGMARK;
+    }
+    return FALSE;
+}
+
 MODULE = File::Glob            PACKAGE = File::Glob
 
 int
 MODULE = File::Glob            PACKAGE = File::Glob
 
 int
@@ -357,6 +392,19 @@ PPCODE:
     csh_glob_iter(aTHX);
     SPAGAIN;
 
     csh_glob_iter(aTHX);
     SPAGAIN;
 
+void
+bsd_glob_override(...)
+PPCODE:
+    if (items >= 2) SP += 2;
+    else {
+       SP += items;
+       XPUSHs(&PL_sv_undef);
+       if (!items) XPUSHs(&PL_sv_undef);
+    }
+    PUTBACK;
+    iterate(aTHX_ doglob_iter_wrapper);
+    SPAGAIN;
+
 BOOT:
 {
 #ifndef PERL_EXTERNAL_GLOB
 BOOT:
 {
 #ifndef PERL_EXTERNAL_GLOB
index df2b958..3fab895 100644 (file)
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 use strict;
     }
 }
 use strict;
-use Test::More tests => 29;
+use Test::More tests => 48;
 BEGIN {use_ok('File::Glob', ':glob')};
 use Cwd ();
 
 BEGIN {use_ok('File::Glob', ':glob')};
 use Cwd ();
 
@@ -252,3 +252,32 @@ is glob('a\"b'), 'a"b', '\ before quote *only* escapes quote';
 is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote';
 is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."';
 is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'";
 is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote';
 is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."';
 is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'";
+
+
+package bsdglob;  # for testing the :bsd_glob export tag
+
+use File::Glob ':bsd_glob';
+use Test::More;
+for (qw[
+        GLOB_ABEND
+       GLOB_ALPHASORT
+        GLOB_ALTDIRFUNC
+        GLOB_BRACE
+        GLOB_CSH
+        GLOB_ERR
+        GLOB_ERROR
+        GLOB_LIMIT
+        GLOB_MARK
+        GLOB_NOCASE
+        GLOB_NOCHECK
+        GLOB_NOMAGIC
+        GLOB_NOSORT
+        GLOB_NOSPACE
+        GLOB_QUOTE
+        GLOB_TILDE
+        bsd_glob
+    ]) {
+    ok (exists &$_, qq':bsd_glob exports $_');
+}
+is <a b>, 'a b', '<a b> under :bsd_glob';
+is <"a" "b">, '"a" "b"', '<"a" "b"> under :bsd_glob';