This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
glob test case tweak for VMS
[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..11\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   eval {
49     ($name, $home) = (getpwuid($>))[0,7];
50     1;
51   } and do {
52     @a = bsd_glob("~$name", GLOB_TILDE);
53     if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) {
54         print "not ";
55     }
56   };
57 }
58 print "ok 3\n";
59
60 # check backslashing
61 # should return a list with one item, and not set ERROR
62 @a = bsd_glob('TEST', GLOB_QUOTE);
63 if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) {
64     local $/ = "][";
65     print "# [@a]\n";
66     print "not ";
67 }
68 print "ok 4\n";
69
70 # check nonexistent checks
71 # should return an empty list
72 # XXX since errfunc is NULL on win32, this test is not valid there
73 @a = bsd_glob("asdfasdf", 0);
74 if (($^O ne 'MSWin32' && $^O ne 'NetWare') and scalar @a != 0) {
75     print "# |@a|\nnot ";
76 }
77 print "ok 5\n";
78
79 # check bad protections
80 # should return an empty list, and set ERROR
81 if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or $^O eq 'VMS'
82     or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>)
83 {
84     print "ok 6 # skipped\n";
85 }
86 else {
87     $dir = "pteerslo";
88     mkdir $dir, 0;
89     @a = bsd_glob("$dir/*", GLOB_ERR);
90     #print "\@a = ", array(@a);
91     rmdir $dir;
92     if (scalar(@a) != 0 || GLOB_ERROR == 0) {
93         print "not ";
94     }
95     print "ok 6\n";
96 }
97
98 # check for csh style globbing
99 @a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC);
100 unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') {
101     print "not ";
102 }
103 print "ok 7\n";
104
105 @a = bsd_glob(
106     '{TES*,doesntexist*,a,b}',
107     GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0)
108 );
109
110 # Working on t/TEST often causes this test to fail because it sees Emacs temp
111 # and RCS files.  Filter them out, and .pm files too, and patch temp files.
112 @a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a;
113 @a = (grep !/test.pl/, @a) if $^O eq 'VMS';
114
115 print "# @a\n";
116
117 unless (@a == 3
118         and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST')
119         and $a[1] eq 'a'
120         and $a[2] eq 'b')
121 {
122     print "not ok 8 # @a\n";
123 } else {
124     print "ok 8\n";
125 }
126
127 # "~" should expand to $ENV{HOME}
128 $ENV{HOME} = "sweet home";
129 @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
130 unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) {
131     print "not ";
132 }
133 print "ok 9\n";
134
135 # GLOB_ALPHASORT (default) should sort alphabetically regardless of case
136 mkdir "pteerslo", 0777;
137 chdir "pteerslo";
138
139 @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl);
140 @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl);
141 if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER
142     @f_names = sort(@f_names);
143 }
144 if ($^O eq 'VMS') { # VMS is happily caseignorant
145     @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl);
146     @f_names = @f_alpha;
147 }
148
149 for (@f_names) {
150     open T, "> $_";
151     close T;
152 }
153
154 $pat = "*.pl";
155
156 $ok = 1;
157 @g_names = bsd_glob($pat, 0);
158 print "# f_names = @f_names\n";
159 print "# g_names = @g_names\n";
160 for (@f_names) {
161     $ok = 0 unless $_ eq shift @g_names;
162 }
163 print $ok ? "ok 10\n" : "not ok 10\n";
164
165 $ok = 1;
166 @g_alpha = bsd_glob($pat);
167 print "# f_alpha = @f_alpha\n";
168 print "# g_alpha = @g_alpha\n";
169 for (@f_alpha) {
170     $ok = 0 unless $_ eq shift @g_alpha;
171 }
172 print $ok ? "ok 11\n" : "not ok 11\n";
173
174 unlink @f_names;
175 chdir "..";
176 rmdir "pteerslo";