ext/File-DosGlob/t/DosGlob.t

   1 #!./perl
   2
   3 #
   4 # test glob() in File::DosGlob
   5 #
   6
   7 # Make sure it can load before other XS extensions
   8 use File::DosGlob;
   9
  10 use FindBin;
  11 use File::Spec::Functions;
  12 BEGIN {
  13     chdir catdir $FindBin::Bin, (updir)x3, 't';
  14     @INC = '../lib';
  15 }
  16
  17 use Test::More tests => 21;
  18
  19 # override it in main::
  20 use File::DosGlob 'glob';
  21
  22 require Cwd;
  23
  24 my $expected;
  25 $expected = $_ = "op/a*.t";
  26 my @r = glob;
  27 is ($_, $expected, 'test if $_ takes as the default');
  28 cmp_ok(@r, '>=', 9) or diag("|@r|");
  29
  30 @r = <*/a*.t>;
  31 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
  32 cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
  33 my $r = scalar @r;
  34
  35 @r = ();
  36 while (defined($_ = <*/a*.t>)) {
  37     print "# $_\n";
  38     push @r, $_;
  39 }
  40 is(scalar @r, $r, 'check scalar context');
  41
  42 @r = ();
  43 for (<*/a*.t>) {
  44     print "# $_\n";
  45     push @r, $_;
  46 }
  47 is(scalar @r, $r, 'check list context');
  48
  49 @r = ();
  50 while (<*/a*.t>) {
  51     print "# $_\n";
  52     push @r, $_;
  53 }
  54 is(scalar @r, $r, 'implicit assign to $_ in while()');
  55
  56 my @s = ();
  57 my $pat = '*/a*.t';
  58 while (glob ($pat)) {
  59     print "# $_\n";
  60     push @s, $_;
  61 }
  62 is("@r", "@s", 'explicit glob() gets assign magic too');
  63
  64 package Foo;
  65 use File::DosGlob 'glob';
  66 use Test::More;
  67 @s = ();
  68 $pat = '*/a*.t';
  69 while (glob($pat)) {
  70     print "# $_\n";
  71     push @s, $_;
  72 }
  73 is("@r", "@s", 'in a different package');
  74
  75 @s = ();
  76 while (<*/a*.t>) {
  77     my $i = 0;
  78     print "# $_ <";
  79     push @s, $_;
  80     while (<*/b*.t>) {
  81         print " $_";
  82         $i++;
  83     }
  84     print " >\n";
  85 }
  86 is("@r", "@s", 'different glob ops maintain independent contexts');
  87
  88 @s = ();
  89 eval <<'EOT';
  90 use File::DosGlob 'GLOBAL_glob';
  91 package Bar;
  92 while (<*/a*.t>) {
  93     my $i = 0;
  94     print "# $_ <";
  95     push @s, $_;
  96     while (glob '*/b*.t') {
  97         print " $_";
  98         $i++;
  99     }
 100     print " >\n";
 101 }
 102 EOT
 103 is("@r", "@s", 'global override');
 104
 105 # Test that a glob pattern containing ()'s works.
 106 # NB. The spaces in the glob patterns need to be backslash escaped.
 107 my $filename_containing_parens = "foo (123) bar";
 108 SKIP: {
 109     skip("can't create '$filename_containing_parens': $!", 9)
 110         unless open my $touch, ">", $filename_containing_parens;
 111     close $touch;
 112
 113     foreach my $pattern ("foo\\ (*", "*)\\ bar", "foo\\ (1*3)\\ bar") {
 114         @r = ();
 115         eval { @r = File::DosGlob::glob($pattern) };
 116         is($@, "", "eval for glob($pattern)");
 117         is(scalar @r, 1);
 118         is($r[0], $filename_containing_parens);
 119     }
 120
 121     1 while unlink $filename_containing_parens;
 122 }
 123
 124 # Test the globbing of a drive relative pattern such as "c:*.pl".
 125 # NB. previous versions of DosGlob inserted "./ after the drive letter to
 126 # make the expansion process work correctly. However, while it is harmless,
 127 # there is no reason for it to be in the result.
 128 my $cwd = Cwd::cwd();
 129 if ($cwd =~ /^([a-zA-Z]:)/) {
 130     my $drive = $1;
 131     @r = ();
 132     # This assumes we're in the "t" directory.
 133     eval { @r = File::DosGlob::glob("${drive}io/*.t") };
 134     ok(@r and !grep !m|^${drive}io/[^/]*\.t$|, @r);
 135 } else {
 136     pass();
 137 }
 138
 139 # Test that our internal data are freed when the caller’s op tree is freed,
 140 # even if iteration has not finished.
 141 # Using XS::APItest is the only simple way to test this.  Since this is a
 142 # core-only module, this should be OK.
 143 SKIP: {
 144     require Config;
 145     skip "no XS::APItest"
 146      unless eval { require XS::APItest; import XS::APItest "sv_count"; 1 };
 147     # Use a random number of ops, so that the glob op does not reuse the
 148     # same address each time, giving us false passes.
 149     my($count,$count2);
 150     eval '$x+'x(1+rand() * 100) . '<*>';
 151     $count = sv_count();
 152     eval '$x+'x(1+rand() * 100) . '<*>';
 153     $count2 = sv_count();
 154     is $count2, $count, 'no leak when partly iterated caller is freed';
 155 }