This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix occasional failures in svleak.t and DosGlob.t
[perl5.git] / 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 catfile $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 }