This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip the right number of tests in DosGlob.t.
[perl5.git] / lib / File / DosGlob.t
1 #!./perl
2
3 #
4 # test glob() in File::DosGlob
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '../lib';
10 }
11
12 use Test::More tests => 20;
13
14 # override it in main::
15 use File::DosGlob 'glob';
16
17 require Cwd;
18
19 my $expected;
20 $expected = $_ = "op/a*.t";
21 my @r = glob;
22 is ($_, $expected, 'test if $_ takes as the default');
23 cmp_ok(@r, '>=', 9) or diag("|@r|");
24
25 @r = <*/a*.t>;
26 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
27 cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
28 my $r = scalar @r;
29
30 @r = ();
31 while (defined($_ = <*/a*.t>)) {
32     print "# $_\n";
33     push @r, $_;
34 }
35 is(scalar @r, $r, 'check scalar context');
36
37 @r = ();
38 for (<*/a*.t>) {
39     print "# $_\n";
40     push @r, $_;
41 }
42 is(scalar @r, $r, 'check list context');
43
44 @r = ();
45 while (<*/a*.t>) {
46     print "# $_\n";
47     push @r, $_;
48 }
49 is(scalar @r, $r, 'implicit assign to $_ in while()');
50
51 my @s = ();
52 my $pat = '*/a*.t';
53 while (glob ($pat)) {
54     print "# $_\n";
55     push @s, $_;
56 }
57 is("@r", "@s", 'explicit glob() gets assign magic too');
58
59 package Foo;
60 use File::DosGlob 'glob';
61 use Test::More;
62 @s = ();
63 $pat = '*/a*.t';
64 while (glob($pat)) {
65     print "# $_\n";
66     push @s, $_;
67 }
68 is("@r", "@s", 'in a different package');
69
70 @s = ();
71 while (<*/a*.t>) {
72     my $i = 0;
73     print "# $_ <";
74     push @s, $_;
75     while (<*/b*.t>) {
76         print " $_";
77         $i++;
78     }
79     print " >\n";
80 }
81 is("@r", "@s", 'different glob ops maintain independent contexts');
82
83 @s = ();
84 eval <<'EOT';
85 use File::DosGlob 'GLOBAL_glob';
86 package Bar;
87 while (<*/a*.t>) {
88     my $i = 0;
89     print "# $_ <";
90     push @s, $_;
91     while (glob '*/b*.t') {
92         print " $_";
93         $i++;
94     }
95     print " >\n";
96 }
97 EOT
98 is("@r", "@s", 'global override');
99
100 # Test that a glob pattern containing ()'s works.
101 # NB. The spaces in the glob patterns need to be backslash escaped.
102 my $filename_containing_parens = "foo (123) bar";
103 SKIP: {
104     skip("can't create '$filename_containing_parens': $!", 9)
105         unless open my $touch, ">", $filename_containing_parens;
106     close $touch;
107
108     foreach my $pattern ("foo\\ (*", "*)\\ bar", "foo\\ (1*3)\\ bar") {
109         @r = ();
110         eval { @r = File::DosGlob::glob($pattern) };
111         is($@, "", "eval for glob($pattern)");
112         is(scalar @r, 1);
113         is($r[0], $filename_containing_parens);
114     }
115
116     1 while unlink $filename_containing_parens;
117 }
118
119 # Test the globbing of a drive relative pattern such as "c:*.pl".
120 # NB. previous versions of DosGlob inserted "./ after the drive letter to
121 # make the expansion process work correctly. However, while it is harmless,
122 # there is no reason for it to be in the result.
123 my $cwd = Cwd::cwd();
124 if ($cwd =~ /^([a-zA-Z]:)/) {
125     my $drive = $1;
126     @r = ();
127     # This assumes we're in the "t" directory.
128     eval { @r = File::DosGlob::glob("${drive}io/*.t") };
129     ok(@r and !grep !m|^${drive}io/[^/]*\.t$|, @r);
130 } else {
131     pass();
132 }