This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4263272a2081a23dd8120d3b2682e9b742aabdc9
[perl5.git] / ext / File / Glob / t / basic.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     if ($^O eq 'MacOS') { 
6         @INC = qw(: ::lib ::macos:lib); 
7     } else { 
8         @INC = '.'; 
9         push @INC, '../lib'; 
10     }
11     require Config; import Config;
12     if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {
13         print "1..0\n";
14         exit 0;
15     }
16     print "1..13\n";
17 }
18 END {
19     print "not ok 1\n" unless $loaded;
20 }
21 use File::Glob ':glob';
22 use Cwd ();
23 $loaded = 1;
24 print "ok 1\n";
25
26 sub array {
27     return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n";
28 }
29
30 # look for the contents of the current directory
31 $ENV{PATH} = "/bin";
32 delete @ENV{BASH_ENV, CDPATH, ENV, IFS};
33 @correct = ();
34 if (opendir(D, $^O eq "MacOS" ? ":" : ".")) {
35    @correct = grep { !/^\./ } sort readdir(D);
36    closedir D;
37 }
38 @a = File::Glob::glob("*", 0);
39 @a = sort @a;
40 if ("@a" ne "@correct" || GLOB_ERROR) {
41     print "# |@a| ne |@correct|\nnot ";
42 }
43 print "ok 2\n";
44
45 # look up the user's home directory
46 # should return a list with one item, and not set ERROR
47 if ($^O ne 'MSWin32' && $^O ne 'NetWare' && $^O ne 'VMS' && $^O ne 'os2'
48     && $^O ne 'beos') {
49   eval {
50     ($name, $home) = (getpwuid($>))[0,7];
51     1;
52   } and do {
53     if (defined $home && defined $name && -d $home) {
54         @a = bsd_glob("~$name", GLOB_TILDE);
55         if ((scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR)) {
56             print "not ";
57         }
58     }
59   };
60 }
61 print "ok 3\n";
62
63 # check backslashing
64 # should return a list with one item, and not set ERROR
65 @a = bsd_glob('TEST', GLOB_QUOTE);
66 if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) {
67     local $/ = "][";
68     print "# [@a]\n";
69     print "not ";
70 }
71 print "ok 4\n";
72
73 # check nonexistent checks
74 # should return an empty list
75 # XXX since errfunc is NULL on win32, this test is not valid there
76 @a = bsd_glob("asdfasdf", 0);
77 if (($^O ne 'MSWin32' && $^O ne 'NetWare') and scalar @a != 0) {
78     print "# |@a|\nnot ";
79 }
80 print "ok 5\n";
81
82 # check bad protections
83 # should return an empty list, and set ERROR
84 if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or $^O eq 'VMS'
85     or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>)
86 {
87     print "ok 6 # skipped\n";
88 }
89 else {
90     $dir = "pteerslo";
91     mkdir $dir, 0;
92     @a = bsd_glob("$dir/*", GLOB_ERR);
93     #print "\@a = ", array(@a);
94     rmdir $dir;
95     if (scalar(@a) != 0 || GLOB_ERROR == 0) {
96         if ($^O eq 'vos') {
97             print "not ok 6 # TODO hit VOS bug posix-956\n";
98         } else {
99             print "not ok 6\n";
100         }
101     }
102     else {
103         print "ok 6\n";
104     }
105 }
106
107 # check for csh style globbing
108 @a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC);
109 unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') {
110     print "not ";
111 }
112 print "ok 7\n";
113
114 @a = bsd_glob(
115     '{TES*,doesntexist*,a,b}',
116     GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0)
117 );
118
119 # Working on t/TEST often causes this test to fail because it sees Emacs temp
120 # and RCS files.  Filter them out, and .pm files too, and patch temp files.
121 @a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a;
122 @a = (grep !/test.pl/, @a) if $^O eq 'VMS';
123
124 print "# @a\n";
125
126 unless (@a == 3
127         and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST')
128         and $a[1] eq 'a'
129         and $a[2] eq 'b')
130 {
131     print "not ok 8 # @a\n";
132 } else {
133     print "ok 8\n";
134 }
135
136 # "~" should expand to $ENV{HOME}
137 $ENV{HOME} = "sweet home";
138 @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
139 unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) {
140     print "not ";
141 }
142 print "ok 9\n";
143
144 # GLOB_ALPHASORT (default) should sort alphabetically regardless of case
145 mkdir "pteerslo", 0777;
146 chdir "pteerslo";
147
148 @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl);
149 @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl);
150 if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER
151     @f_names = sort(@f_names);
152 }
153 if ($^O eq 'VMS') { # VMS is happily caseignorant
154     @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl);
155     @f_names = @f_alpha;
156 }
157
158 for (@f_names) {
159     open T, "> $_";
160     close T;
161 }
162
163 $pat = "*.pl";
164
165 $ok = 1;
166 @g_names = bsd_glob($pat, 0);
167 print "# f_names = @f_names\n";
168 print "# g_names = @g_names\n";
169 for (@f_names) {
170     $ok = 0 unless $_ eq shift @g_names;
171 }
172 print $ok ? "ok 10\n" : "not ok 10\n";
173
174 $ok = 1;
175 @g_alpha = bsd_glob($pat);
176 print "# f_alpha = @f_alpha\n";
177 print "# g_alpha = @g_alpha\n";
178 for (@f_alpha) {
179     $ok = 0 unless $_ eq shift @g_alpha;
180 }
181 print $ok ? "ok 11\n" : "not ok 11\n";
182
183 unlink @f_names;
184 chdir "..";
185 rmdir "pteerslo";
186
187 # this can panic if PL_glob_index gets passed as flags to bsd_glob
188 <*>; <*>;
189 print "ok 12\n";
190
191 {
192     use File::Temp qw(tempdir);
193     use File::Spec qw();
194
195     my($dir) = tempdir(CLEANUP => 1)
196         or die "Could not create temporary directory";
197     for my $file (qw(a_dej a_ghj a_qej)) {
198         open my $fh, ">", File::Spec->catfile($dir, $file)
199             or die "Could not create file $dir/$file: $!";
200         close $fh;
201     }
202     my $cwd = Cwd::cwd();
203     chdir $dir
204         or die "Could not chdir to $dir: $!";
205     my(@glob_files) = glob("a*{d[e]}j");
206     if (!(@glob_files == 1 && "@glob_files" eq "a_dej")) {
207         print "not ";
208     }
209     my $todo = $^O ne 'VMS' ? '' : " # TODO home-made glob doesn't do regexes";
210     print "ok 13$todo\n";
211     chdir $cwd
212         or die "Could not chdir back to $cwd: $!";
213 }