1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; import Config; 7 if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { 8 print "1..0\n"; 9 exit 0; 10 } 11} 12use strict; 13use Test::More tests => 56; 14BEGIN {use_ok('File::Glob', ':glob')}; 15use Cwd (); 16 17my $vms_unix_rpt = 0; 18my $vms_efs = 0; 19my $vms_mode = 0; 20if ($^O eq 'VMS') { 21 if (eval 'require VMS::Feature') { 22 $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); 23 $vms_efs = VMS::Feature::current("efs_charset"); 24 } else { 25 my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 26 my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; 27 $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; 28 $vms_efs = $efs_charset =~ /^[ET1]/i; 29 } 30 $vms_mode = 1 unless ($vms_unix_rpt); 31} 32 33 34# look for the contents of the current directory 35# try it in a directory that doesn't get modified during testing, 36# so parallel testing won't give us race conditions. t/base/ seems 37# fairly static 38 39chdir 'base' or die "chdir base: $!"; 40$ENV{PATH} = "/bin"; 41delete @ENV{qw(BASH_ENV CDPATH ENV IFS)}; 42my @correct = (); 43if (opendir(D, ".")) { 44 @correct = grep { !/^\./ } sort readdir(D); 45 closedir D; 46} 47 48is( 49 File::Glob->can('glob'), 50 undef, 51 'Did not find glob() function in File::Glob', 52); 53 54chdir '..' or die "chdir .. $!"; 55 56# look up the user's home directory 57# should return a list with one item, and not set ERROR 58my @a; 59 60SKIP: { 61 my ($name, $home); 62 skip $^O, 2 if $^O eq 'MSWin32' || $^O eq 'VMS' 63 || $^O eq 'os2'; 64 skip "Can't find user for $>: $@", 2 unless eval { 65 ($name, $home) = (getpwuid($>))[0,7]; 66 1; 67 }; 68 skip "$> has no home directory", 2 69 unless defined $home && defined $name && -d $home; 70 71 @a = bsd_glob("~$name", GLOB_TILDE); 72 73 if (GLOB_ERROR) { 74 fail(GLOB_ERROR); 75 } else { 76 is_deeply (\@a, [$home], 77 "GLOB_TILDE expands patterns that start with '~' to user name home directories" 78 ); 79 } 80 81 my @b = bsd_glob("~$name", GLOB_TILDE | GLOB_MARK); 82 83 if (GLOB_ERROR) { 84 fail(GLOB_ERROR); 85 } else { 86 is_deeply (\@b, ["$home/"], 87 "GLOB_MARK matches directories with path separator attached" 88 ); 89 } 90} 91# check plain tilde expansion 92{ 93 my $tilde_check = sub { 94 my @a = bsd_glob('~'); 95 96 if (GLOB_ERROR) { 97 fail(GLOB_ERROR); 98 } else { 99 is_deeply (\@a, [$_[0]], join ' - ', 'tilde expansion', @_ > 1 ? $_[1] : ()); 100 } 101 }; 102 my $passwd_home = eval { (getpwuid($>))[7] }; 103 104 TODO: { 105 local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS'; 106 local $ENV{HOME}; 107 delete $ENV{HOME}; 108 local $ENV{USERPROFILE}; 109 delete $ENV{USERPROFILE}; 110 $tilde_check->(defined $passwd_home ? $passwd_home : q{~}, 'no environment'); 111 } 112 113 SKIP: { 114 skip 'MSWin32 only', 1 if $^O ne 'MSWin32'; 115 local $ENV{HOME}; 116 delete $ENV{HOME}; 117 local $ENV{USERPROFILE}; 118 $ENV{USERPROFILE} = 'sweet win32 home'; 119 $tilde_check->(defined $passwd_home ? $passwd_home : $ENV{USERPROFILE}, 'USERPROFILE'); 120 } 121 122 TODO: { 123 local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS'; 124 my $home = exists $ENV{HOME} ? $ENV{HOME} 125 : eval { getpwuid($>); 1 } ? (getpwuid($>))[7] 126 : $^O eq 'MSWin32' && exists $ENV{USERPROFILE} ? $ENV{USERPROFILE} 127 : q{~}; 128 $tilde_check->($home); 129 } 130} 131 132# check backslashing 133# should return a list with one item, and not set ERROR 134@a = bsd_glob('TEST', GLOB_QUOTE); 135if (GLOB_ERROR) { 136 fail(GLOB_ERROR); 137} else { 138 is_deeply(\@a, ['TEST'], "GLOB_QUOTE works as expected"); 139} 140 141# check nonexistent checks 142# should return an empty list 143# XXX since errfunc is NULL on win32, this test is not valid there 144SKIP: { 145 skip $^O, 5 if $^O eq 'MSWin32'; 146 my @a = bsd_glob("asdfasdf", 0); 147 is_deeply(\@a, [], "bsd_glob() works as expected for unmatched pattern and 0 flag"); 148 149 my $pattern = "asdfasdf"; 150 @a = bsd_glob($pattern, GLOB_NOCHECK); 151 is(scalar @a, 1, 152 "unmatched pattern with GLOB_NOCHECK returned single-item list"); 153 cmp_ok($a[0], 'eq', $pattern, 154 "bsd_glob() works as expected for unmatched pattern and GLOB_NOCHECK flag"); 155 156 my @b = bsd_glob($pattern, GLOB_NOCHECK | GLOB_QUOTE); 157 is(scalar @b, 1, 158 "unmatched pattern with GLOB_NOCHECK and GLOB_QUOTE returned single-item list"); 159 cmp_ok($b[0], 'eq', $pattern, 160 "bsd_glob() works as expected for unmatched pattern and GLOB_NOCHECK and GLOB_QUOTE flags"); 161} 162 163# check bad protections 164# should return an empty list, and set ERROR 165SKIP: { 166 skip $^O, 2 if $^O eq 'MSWin32' 167 or $^O eq 'os2' or $^O eq 'VMS' or $^O eq 'cygwin'; 168 skip "AFS", 2 if Cwd::cwd() =~ m#^$Config{'afsroot'}#s; 169 skip "running as root", 2 if not $>; 170 171 my $dir = "pteerslo"; 172 mkdir $dir, 0; 173 @a = bsd_glob("$dir/*", GLOB_ERR); 174 rmdir $dir; 175 local $TODO = 'hit VOS bug posix-956' if $^O eq 'vos'; 176 177 isnt(GLOB_ERROR, 0, "GLOB_ERROR is not 0"); 178 is_deeply(\@a, [], "Got empty list as expected"); 179} 180 181# check for csh style globbing 182@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); 183is_deeply(\@a, ['a', 'b'], "Check for csh-style globbing"); 184 185@a = bsd_glob( 186 '{TES*,doesntexist*,a,b}', 187 GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) 188); 189 190# Working on t/TEST often causes this test to fail because it sees Emacs temp 191# and RCS files. Filter them out, and .pm files too, and patch temp files. 192@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; 193@a = (grep !/test.pl/, @a) if $^O eq 'VMS'; 194 195map { $_ =~ s/test\.?/TEST/i } @a if $^O eq 'VMS'; 196print "# @a\n"; 197 198is_deeply(\@a, ['TEST', 'a', 'b'], "Got list of 3 elements, including 'TEST'"); 199 200# "~" should expand to $ENV{HOME} 201{ 202 local $ENV{HOME} = "sweet home"; 203 @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); 204 is_deeply(\@a, [$ENV{HOME}], "~ expands to envvar \$HOME"); 205} 206 207# GLOB_ALPHASORT (default) should sort alphabetically regardless of case 208mkdir "pteerslo", 0777 or die "mkdir 'pteerslo', 0777: $!"; 209chdir "pteerslo" or die "chdir 'pteerslo' $!"; 210 211my @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); 212my @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); 213if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER 214 @f_names = sort(@f_names); 215} 216if ($^O eq 'VMS') { # VMS is happily caseignorant 217 @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); 218 @f_names = @f_alpha; 219} 220 221for (@f_names) { 222 open T, '>', $_ or die "Couldn't write to '$_': $!"; 223 close T or die "Couldn't close '$_': $!"; 224} 225 226my $pat = "*.pl"; 227 228my @g_names = bsd_glob($pat, 0); 229print "# f_names = @f_names\n"; 230print "# g_names = @g_names\n"; 231is_deeply(\@g_names, \@f_names, "Got expected case-sensitive list of filenames"); 232 233my @g_alpha = bsd_glob($pat); 234print "# f_alpha = @f_alpha\n"; 235print "# g_alpha = @g_alpha\n"; 236is_deeply(\@g_alpha, \@f_alpha, "Got expected case-insensitive list of filenames"); 237 238my @h_alpha = bsd_glob($pat, GLOB_ALPHASORT); 239print "# f_alpha = @f_alpha\n"; 240print "# h_alpha = @h_alpha\n"; 241is_deeply(\@h_alpha, \@f_alpha, 242 "Got expected case-insensitive list of filenames (explicit GLOB_ALPHASORT)"); 243 244my (%h_seen, %i_seen); 245map { $h_seen{$_} => 1 } @h_alpha; 246map { $i_seen{$_} => 1 } bsd_glob($pat, GLOB_NOSORT); 247is_deeply(\%h_seen, \%i_seen, 248 "GLOB_NOSORT saw same names as default (though probably not in same order)"); 249 250unlink @f_names; 251chdir ".."; 252rmdir "pteerslo"; 253 254# this can panic if PL_glob_index gets passed as flags to bsd_glob 255<*>; <*>; 256pass("Don't panic"); 257 258{ 259 use File::Temp qw(tempdir); 260 use File::Spec qw(); 261 262 my($dir) = tempdir(CLEANUP => 1) 263 or die "Could not create temporary directory"; 264 for my $file (qw(a_dej a_ghj a_qej)) { 265 open my $fh, ">", File::Spec->catfile($dir, $file) 266 or die "Could not create file $dir/$file: $!"; 267 close $fh; 268 } 269 my $cwd = Cwd::cwd(); 270 chdir $dir 271 or die "Could not chdir to $dir: $!"; 272 my(@glob_files) = glob("a*{d[e]}j"); 273 chdir $cwd 274 or die "Could not chdir back to $cwd: $!"; 275 local $TODO = "home-made glob doesn't do regexes" if $^O eq 'VMS'; 276 is_deeply(\@glob_files, ['a_dej'], 277 "Got expected list: metacharacters and character class in pattern"); 278} 279 280# This used to segfault. 281my $i = bsd_glob('*', GLOB_ALTDIRFUNC); 282is(&File::Glob::GLOB_ERROR, 0, "Successfuly ignored unsupported flag"); 283 284package frimpy; # get away from the glob override, so we can test csh_glob, 285use Test::More; # which is perl's default 286 287# In case of PERL_EXTERNAL_GLOB: 288use subs 'glob'; 289BEGIN { *glob = \&File::Glob::csh_glob } 290 291is +(glob "a'b'")[0], (<a'b' c>)[0], "a'b' with and without spaces"; 292is <a"b">, 'ab', 'a"b" without spaces'; 293is_deeply [<a"b" c>], [qw<ab c>], 'a"b" without spaces'; 294is_deeply [<\\* .\\*>], [<\\*>,<.\\*>], 'backslashes with(out) spaces'; 295like <\\ >, qr/^\\? \z/, 'final escaped space'; 296is <a"b>, 'a"b', 'unmatched quote'; 297is < a"b >, 'a"b', 'unmatched quote with surrounding spaces'; 298is glob('a\"b'), 'a"b', '\ before quote *only* escapes quote'; 299is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote'; 300is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."'; 301is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'"; 302 303 304package bsdglob; # for testing the :bsd_glob export tag 305 306use File::Glob ':bsd_glob'; 307use Test::More; 308for (qw[ 309 GLOB_ABEND 310 GLOB_ALPHASORT 311 GLOB_ALTDIRFUNC 312 GLOB_BRACE 313 GLOB_CSH 314 GLOB_ERR 315 GLOB_ERROR 316 GLOB_LIMIT 317 GLOB_MARK 318 GLOB_NOCASE 319 GLOB_NOCHECK 320 GLOB_NOMAGIC 321 GLOB_NOSORT 322 GLOB_NOSPACE 323 GLOB_QUOTE 324 GLOB_TILDE 325 bsd_glob 326 ]) { 327 ok (exists &$_, qq':bsd_glob exports $_'); 328} 329is <a b>, 'a b', '<a b> under :bsd_glob'; 330is <"a" "b">, '"a" "b"', '<"a" "b"> under :bsd_glob'; 331is_deeply [<a b>], [q<a b>], '<> in list context under :bsd_glob'; 332