1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
#!./perl
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
print "1..10\n";
}
END {
print "not ok 1\n" unless $loaded;
}
BEGIN {
*CORE::GLOBAL::glob = sub { "Just another Perl hacker," };
}
BEGIN {
if ("Just another Perl hacker," ne (<*>)[0]) {
die <<EOMessage;
Your version of perl ($]) doesn't seem to allow extensions to override
the core glob operator.
EOMessage
}
}
use File::Glob ':globally';
$loaded = 1;
print "ok 1\n";
$_ = "lib/*.t";
my @r = glob;
print "not " if $_ ne 'lib/*.t';
print "ok 2\n";
# we should have at least basic.t, global.t, taint.t
print "# |@r|\nnot " if @r < 3;
print "ok 3\n";
# check if <*/*> works
@r = <*/*.t>;
# at least t/global.t t/basic.t, t/taint.t
print "not " if @r < 3;
print "ok 4\n";
my $r = scalar @r;
# check if scalar context works
@r = ();
while (defined($_ = <*/*.t>)) {
#print "# $_\n";
push @r, $_;
}
print "not " if @r != $r;
print "ok 5\n";
# check if array context works
@r = ();
for (<*/*.t>) {
#print "# $_\n";
push @r, $_;
}
print "not " if @r != $r;
print "ok 6\n";
# test if implicit assign to $_ in while() works
@r = ();
while (<*/*.t>) {
#print "# $_\n";
push @r, $_;
}
print "not " if @r != $r;
print "ok 7\n";
# test if explicit glob() gets assign magic too
my @s = ();
while (glob '*/*.t') {
#print "# $_\n";
push @s, $_;
}
print "not " if "@r" ne "@s";
print "ok 8\n";
# how about in a different package, like?
package Foo;
use File::Glob ':globally';
@s = ();
while (glob '*/*.t') {
#print "# $_\n";
push @s, $_;
}
print "not " if "@r" ne "@s";
print "ok 9\n";
# test if different glob ops maintain independent contexts
@s = ();
my $i = 0;
while (<*/*.t>) {
#print "# $_ <";
push @s, $_;
while (<bas*/*.t>) {
#print " $_";
$i++;
}
#print " >\n";
}
print "not " if "@r" ne "@s" or not $i;
print "ok 10\n";
|
