This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #71712] fixes for File::DosGlob
[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 print "1..17\n";
13
14 # override it in main::
15 use File::DosGlob 'glob';
16
17 require Cwd;
18
19 # test if $_ takes as the default
20 my $expected;
21 if ($^O eq 'MacOS') {
22     $expected = $_ = ":op:a*.t";
23 } else {
24     $expected = $_ = "op/a*.t";
25 }
26 my @r = glob;
27 print "not " if $_ ne $expected;
28 print "ok 1\n";
29 print "# |@r|\nnot " if @r < 9;
30 print "ok 2\n";
31
32 # check if <*/*> works
33 if ($^O eq 'MacOS') {
34     @r = <:*:a*.t>;
35 } else {
36     @r = <*/a*.t>;
37 }
38 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
39 print "# |@r|\nnot " if @r < 9;
40 print "ok 3\n";
41 my $r = scalar @r;
42
43 # check if scalar context works
44 @r = ();
45 while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) {
46     print "# $_\n";
47     push @r, $_;
48 }
49 print "not " if @r != $r;
50 print "ok 4\n";
51
52 # check if list context works
53 @r = ();
54 if ($^O eq 'MacOS') {
55     for (<:*:a*.t>) {
56         print "# $_\n";
57         push @r, $_;
58     }
59 } else {
60     for (<*/a*.t>) {
61         print "# $_\n";
62         push @r, $_;
63     }
64 }
65 print "not " if @r != $r;
66 print "ok 5\n";
67
68 # test if implicit assign to $_ in while() works
69 @r = ();
70 if ($^O eq 'MacOS') {
71     while (<:*:a*.t>) {
72         print "# $_\n";
73         push @r, $_;
74     }
75 } else {
76     while (<*/a*.t>) {
77         print "# $_\n";
78         push @r, $_;
79     }
80 }
81 print "not " if @r != $r;
82 print "ok 6\n";
83
84 # test if explicit glob() gets assign magic too
85 my @s = ();
86 my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t';
87 while (glob ($pat)) {
88     print "# $_\n";
89     push @s, $_;
90 }
91 print "not " if "@r" ne "@s";
92 print "ok 7\n";
93
94 # how about in a different package, like?
95 package Foo;
96 use File::DosGlob 'glob';
97 @s = ();
98 $pat = $^O eq 'MacOS' ? ':*:a*.t' : '*/a*.t';
99 while (glob($pat)) {
100     print "# $_\n";
101     push @s, $_;
102 }
103 print "not " if "@r" ne "@s";
104 print "ok 8\n";
105
106 # test if different glob ops maintain independent contexts
107 @s = ();
108 if ($^O eq 'MacOS') {
109     while (<:*:a*.t>) {
110         my $i = 0;
111         print "# $_ <";
112         push @s, $_;
113         while (<:*:b*.t>) {
114             print " $_";
115             $i++;
116         }
117         print " >\n";
118     }
119 } else {
120     while (<*/a*.t>) {
121         my $i = 0;
122         print "# $_ <";
123         push @s, $_;
124         while (<*/b*.t>) {
125             print " $_";
126             $i++;
127         }
128         print " >\n";
129     }
130 }
131 print "not " if "@r" ne "@s";
132 print "ok 9\n";
133
134 # how about a global override, hm?
135 eval <<'EOT';
136 use File::DosGlob 'GLOBAL_glob';
137 package Bar;
138 @s = ();
139 if ($^O eq 'MacOS') {
140     while (<:*:a*.t>) {
141         my $i = 0;
142         print "# $_ <";
143         push @s, $_;
144         while (glob ':*:b*.t') {
145             print " $_";
146             $i++;
147         }
148         print " >\n";
149     }
150 } else {
151     while (<*/a*.t>) {
152         my $i = 0;
153         print "# $_ <";
154         push @s, $_;
155         while (glob '*/b*.t') {
156             print " $_";
157             $i++;
158         }
159         print " >\n";
160     }
161 }
162 print "not " if "@r" ne "@s";
163 print "ok 10\n";
164 EOT
165
166 # Test that a glob pattern containing ()'s works.
167 # NB. The spaces in the glob patters need to be backslash escaped.
168 my $filename_containing_parens = "foo (123) bar";
169 open(TOUCH, ">", $filename_containing_parens) && close(TOUCH)
170     or die "can't create '$filename_containing_parens': $!";
171
172 @r = ();
173 eval { @r = File::DosGlob::glob("foo\\ (*") };
174 print +($@ ? "not " : ""), "ok 11\n";
175 print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
176 print "ok 12\n";
177
178 @r = ();
179 eval { @r = File::DosGlob::glob("*)\\ bar") };
180 print +($@ ? "not " : ""), "ok 13\n";
181 print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
182 print "ok 14\n";
183
184 @r = ();
185 eval { @r = File::DosGlob::glob("foo\\ (1*3)\\ bar") };
186 print +($@ ? "not " : ""), "ok 15\n";
187 print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
188 print "ok 16\n";
189
190 unlink $filename_containing_parens;
191
192 # Test the globbing of a drive relative pattern such as "c:*.pl".
193 # NB. previous versions of DosGlob inserted "./ after the drive letter to
194 # make the expansion process work correctly. However, while it is harmless,
195 # there is no reason for it to be in the result.
196 my $cwd = Cwd::cwd();
197 if ($cwd =~ /^([a-zA-Z]:)/) {
198     my $drive = $1;
199     @r = ();
200     # This assumes we're in the "t" directory.
201     eval { @r = File::DosGlob::glob("${drive}io/*.t") };
202     print +((@r and !grep !m|^${drive}io/[^/]*\.t$|, @r) ? "" : "not "), "ok 17\n";
203 } else {
204     print "ok 17\n";
205 }