1#!./perl
2
3#
4# test glob() in File::DosGlob
5#
6
7# Make sure it can load before other XS extensions
8use File::DosGlob;
9
10use FindBin;
11use File::Spec::Functions;
12BEGIN {
13    chdir catdir $FindBin::Bin, (updir)x3, 't';
14    @INC = '../lib';
15}
16
17use Test::More tests => 21;
18
19# override it in main::
20use File::DosGlob 'glob';
21
22require Cwd;
23
24my $expected;
25$expected = $_ = "op/a*.t";
26my @r = glob;
27is ($_, $expected, 'test if $_ takes as the default');
28cmp_ok(@r, '>=', 9) or diag("|@r|");
29
30@r = <*/a*.t>;
31# at least {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
32cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
33my $r = scalar @r;
34
35@r = ();
36while (defined($_ = <*/a*.t>)) {
37    print "# $_\n";
38    push @r, $_;
39}
40is(scalar @r, $r, 'check scalar context');
41
42@r = ();
43for (<*/a*.t>) {
44    print "# $_\n";
45    push @r, $_;
46}
47is(scalar @r, $r, 'check list context');
48
49@r = ();
50while (<*/a*.t>) {
51    print "# $_\n";
52    push @r, $_;
53}
54is(scalar @r, $r, 'implicit assign to $_ in while()');
55
56my @s = ();
57my $pat = '*/a*.t';
58while (glob ($pat)) {
59    print "# $_\n";
60    push @s, $_;
61}
62is("@r", "@s", 'explicit glob() gets assign magic too');
63
64package Foo;
65use File::DosGlob 'glob';
66use Test::More;
67@s = ();
68$pat = '*/a*.t';
69while (glob($pat)) {
70    print "# $_\n";
71    push @s, $_;
72}
73is("@r", "@s", 'in a different package');
74
75@s = ();
76while (<*/a*.t>) {
77    my $i = 0;
78    print "# $_ <";
79    push @s, $_;
80    while (<*/b*.t>) {
81	print " $_";
82	$i++;
83    }
84    print " >\n";
85}
86is("@r", "@s", 'different glob ops maintain independent contexts');
87
88@s = ();
89eval <<'EOT';
90use File::DosGlob 'GLOBAL_glob';
91package Bar;
92while (<*/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}
102EOT
103is("@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.
107my $filename_containing_parens = "foo (123) bar";
108SKIP: {
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.
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") };
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.
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(1+rand() * 100) . '<*>';
151    $count = sv_count();
152    eval '$x+'x(1+rand() * 100) . '<*>';
153    $count2 = sv_count();
154    cmp_ok $count2, '<=', $count,
155     'no leak when partly iterated caller is freed';
156}
157