This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DosGlob: Don’t leak when caller’s op tree is freed
[perl5.git] / ext / File-DosGlob / t / DosGlob.t
CommitLineData
fb73857a
PP
1#!./perl
2
3#
4# test glob() in File::DosGlob
5#
6
c619428f
FC
7# Make sure it can load before other XS extensions
8use File::DosGlob;
9
005b65f9
FC
10use FindBin;
11use File::Spec::Functions;
fb73857a 12BEGIN {
005b65f9 13 chdir catfile $FindBin::Bin, (updir)x3, 't';
20822f61 14 @INC = '../lib';
fb73857a
PP
15}
16
7fddb138 17use Test::More tests => 21;
fb73857a
PP
18
19# override it in main::
20use File::DosGlob 'glob';
21
2f3c8ce9
AD
22require Cwd;
23
be708cc0 24my $expected;
7d38af62 25$expected = $_ = "op/a*.t";
fb73857a 26my @r = glob;
dd2d1456
NC
27is ($_, $expected, 'test if $_ takes as the default');
28cmp_ok(@r, '>=', 9) or diag("|@r|");
fb73857a 29
7d38af62 30@r = <*/a*.t>;
fb73857a 31# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
dd2d1456 32cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
fb73857a
PP
33my $r = scalar @r;
34
fb73857a 35@r = ();
7d38af62 36while (defined($_ = <*/a*.t>)) {
fb73857a
PP
37 print "# $_\n";
38 push @r, $_;
39}
dd2d1456 40is(scalar @r, $r, 'check scalar context');
fb73857a 41
fb73857a 42@r = ();
7d38af62
NC
43for (<*/a*.t>) {
44 print "# $_\n";
45 push @r, $_;
fb73857a 46}
dd2d1456 47is(scalar @r, $r, 'check list context');
fb73857a 48
fb73857a 49@r = ();
7d38af62
NC
50while (<*/a*.t>) {
51 print "# $_\n";
52 push @r, $_;
fb73857a 53}
dd2d1456 54is(scalar @r, $r, 'implicit assign to $_ in while()');
fb73857a 55
fb73857a 56my @s = ();
7d38af62 57my $pat = '*/a*.t';
be708cc0 58while (glob ($pat)) {
fb73857a
PP
59 print "# $_\n";
60 push @s, $_;
61}
dd2d1456 62is("@r", "@s", 'explicit glob() gets assign magic too');
fb73857a 63
fb73857a
PP
64package Foo;
65use File::DosGlob 'glob';
dd2d1456 66use Test::More;
fb73857a 67@s = ();
7d38af62 68$pat = '*/a*.t';
d5201bd2 69while (glob($pat)) {
fb73857a
PP
70 print "# $_\n";
71 push @s, $_;
72}
dd2d1456 73is("@r", "@s", 'in a different package');
fb73857a 74
fb73857a 75@s = ();
7d38af62
NC
76while (<*/a*.t>) {
77 my $i = 0;
78 print "# $_ <";
79 push @s, $_;
80 while (<*/b*.t>) {
81 print " $_";
82 $i++;
fb73857a 83 }
7d38af62 84 print " >\n";
fb73857a 85}
dd2d1456 86is("@r", "@s", 'different glob ops maintain independent contexts');
fb73857a 87
dd2d1456 88@s = ();
95d94a4f
GS
89eval <<'EOT';
90use File::DosGlob 'GLOBAL_glob';
91package Bar;
7d38af62
NC
92while (<*/a*.t>) {
93 my $i = 0;
94 print "# $_ <";
95 push @s, $_;
96 while (glob '*/b*.t') {
97 print " $_";
98 $i++;
95d94a4f 99 }
7d38af62 100 print " >\n";
95d94a4f 101}
95d94a4f 102EOT
dd2d1456 103is("@r", "@s", 'global override');
2f3c8ce9
AD
104
105# Test that a glob pattern containing ()'s works.
83f61a2e 106# NB. The spaces in the glob patterns need to be backslash escaped.
2f3c8ce9 107my $filename_containing_parens = "foo (123) bar";
dd2d1456 108SKIP: {
723bc154 109 skip("can't create '$filename_containing_parens': $!", 9)
dd2d1456
NC
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 }
2f3c8ce9 120
83f61a2e
CB
121 1 while unlink $filename_containing_parens;
122}
2f3c8ce9
AD
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.
128my $cwd = Cwd::cwd();
129if ($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") };
dd2d1456 134 ok(@r and !grep !m|^${drive}io/[^/]*\.t$|, @r);
2f3c8ce9 135} else {
dd2d1456 136 pass();
2f3c8ce9 137}
7fddb138
FC
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.
143SKIP: {
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(rand() * 100) . '<*>';
151 $count = sv_count();
152 eval '$x+'x(rand() * 100) . '<*>';
153 $count2 = sv_count();
154 is $count2, $count, 'no leak when partly iterated caller is freed';
155}