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 => 49; 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{ 48 local $@; 49 my $expect = 50 qr/File::Glob::glob\(\) was removed in perl 5\.30\. Use File::Glob::bsd_glob\(\) instead/; 51 eval { File::Glob::glob("*", 0); }; 52 like $@, $expect, 53 "Got expected error message for removal of File::Glob::glob()"; 54} 55chdir '..' or die "chdir .. $!"; 56 57# look up the user's home directory 58# should return a list with one item, and not set ERROR 59my @a; 60 61SKIP: { 62 my ($name, $home); 63 skip $^O, 1 if $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' 64 || $^O eq 'os2'; 65 skip "Can't find user for $>: $@", 1 unless eval { 66 ($name, $home) = (getpwuid($>))[0,7]; 67 1; 68 }; 69 skip "$> has no home directory", 1 70 unless defined $home && defined $name && -d $home; 71 72 @a = bsd_glob("~$name", GLOB_TILDE); 73 74 if (GLOB_ERROR) { 75 fail(GLOB_ERROR); 76 } else { 77 is_deeply (\@a, [$home], 78 "GLOB_TILDE expands patterns that start with '~' to user name home directories" 79 ); 80 } 81} 82# check plain tilde expansion 83{ 84 my $tilde_check = sub { 85 my @a = bsd_glob('~'); 86 87 if (GLOB_ERROR) { 88 fail(GLOB_ERROR); 89 } else { 90 is_deeply (\@a, [$_[0]], join ' - ', 'tilde expansion', @_ > 1 ? $_[1] : ()); 91 } 92 }; 93 my $passwd_home = eval { (getpwuid($>))[7] }; 94 95 TODO: { 96 local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS'; 97 local $ENV{HOME}; 98 delete $ENV{HOME}; 99 local $ENV{USERPROFILE}; 100 delete $ENV{USERPROFILE}; 101 $tilde_check->(defined $passwd_home ? $passwd_home : q{~}, 'no environment'); 102 } 103 104 SKIP: { 105 skip 'MSWin32 only', 1 if $^O ne 'MSWin32'; 106 local $ENV{HOME}; 107 delete $ENV{HOME}; 108 local $ENV{USERPROFILE}; 109 $ENV{USERPROFILE} = 'sweet win32 home'; 110 $tilde_check->(defined $passwd_home ? $passwd_home : $ENV{USERPROFILE}, 'USERPROFILE'); 111 } 112 113 TODO: { 114 local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS'; 115 my $home = exists $ENV{HOME} ? $ENV{HOME} 116 : eval { getpwuid($>); 1 } ? (getpwuid($>))[7] 117 : $^O eq 'MSWin32' && exists $ENV{USERPROFILE} ? $ENV{USERPROFILE} 118 : q{~}; 119 $tilde_check->($home); 120 } 121} 122 123# check backslashing 124# should return a list with one item, and not set ERROR 125@a = bsd_glob('TEST', GLOB_QUOTE); 126if (GLOB_ERROR) { 127 fail(GLOB_ERROR); 128} else { 129 is_deeply(\@a, ['TEST'], "GLOB_QUOTE works as expected"); 130} 131 132# check nonexistent checks 133# should return an empty list 134# XXX since errfunc is NULL on win32, this test is not valid there 135@a = bsd_glob("asdfasdf", 0); 136SKIP: { 137 skip $^O, 1 if $^O eq 'MSWin32' || $^O eq 'NetWare'; 138 is_deeply(\@a, [], "bsd_glob() works as expected for unmatched pattern and 0 flag"); 139} 140 141# check bad protections 142# should return an empty list, and set ERROR 143SKIP: { 144 skip $^O, 2 if $^O eq 'MSWin32' or $^O eq 'NetWare' 145 or $^O eq 'os2' or $^O eq 'VMS' or $^O eq 'cygwin'; 146 skip "AFS", 2 if Cwd::cwd() =~ m#^$Config{'afsroot'}#s; 147 skip "running as root", 2 if not $>; 148 149 my $dir = "pteerslo"; 150 mkdir $dir, 0; 151 @a = bsd_glob("$dir/*", GLOB_ERR); 152 rmdir $dir; 153 local $TODO = 'hit VOS bug posix-956' if $^O eq 'vos'; 154 155 isnt(GLOB_ERROR, 0, "GLOB_ERROR is not 0"); 156 is_deeply(\@a, [], "Got empty list as expected"); 157} 158 159# check for csh style globbing 160@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); 161is_deeply(\@a, ['a', 'b'], "Check for csh-style globbing"); 162 163@a = bsd_glob( 164 '{TES*,doesntexist*,a,b}', 165 GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) 166); 167 168# Working on t/TEST often causes this test to fail because it sees Emacs temp 169# and RCS files. Filter them out, and .pm files too, and patch temp files. 170@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; 171@a = (grep !/test.pl/, @a) if $^O eq 'VMS'; 172 173map { $_ =~ s/test\.?/TEST/i } @a if $^O eq 'VMS'; 174print "# @a\n"; 175 176is_deeply(\@a, ['TEST', 'a', 'b'], "Got list of 3 elements, including 'TEST'"); 177 178# "~" should expand to $ENV{HOME} 179{ 180 local $ENV{HOME} = "sweet home"; 181 @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); 182 is_deeply(\@a, [$ENV{HOME}], "~ expands to envvar \$HOME"); 183} 184 185# GLOB_ALPHASORT (default) should sort alphabetically regardless of case 186mkdir "pteerslo", 0777; 187chdir "pteerslo"; 188 189my @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); 190my @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); 191if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER 192 @f_names = sort(@f_names); 193} 194if ($^O eq 'VMS') { # VMS is happily caseignorant 195 @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); 196 @f_names = @f_alpha; 197} 198 199for (@f_names) { 200 open T, '>', $_; 201 close T; 202} 203 204my $pat = "*.pl"; 205 206my @g_names = bsd_glob($pat, 0); 207print "# f_names = @f_names\n"; 208print "# g_names = @g_names\n"; 209is_deeply(\@g_names, \@f_names, "Got expected case-sensitive list of filenames"); 210 211my @g_alpha = bsd_glob($pat); 212print "# f_alpha = @f_alpha\n"; 213print "# g_alpha = @g_alpha\n"; 214is_deeply(\@g_alpha, \@f_alpha, "Got expected case-insensitive list of filenames"); 215 216unlink @f_names; 217chdir ".."; 218rmdir "pteerslo"; 219 220# this can panic if PL_glob_index gets passed as flags to bsd_glob 221<*>; <*>; 222pass("Don't panic"); 223 224{ 225 use File::Temp qw(tempdir); 226 use File::Spec qw(); 227 228 my($dir) = tempdir(CLEANUP => 1) 229 or die "Could not create temporary directory"; 230 for my $file (qw(a_dej a_ghj a_qej)) { 231 open my $fh, ">", File::Spec->catfile($dir, $file) 232 or die "Could not create file $dir/$file: $!"; 233 close $fh; 234 } 235 my $cwd = Cwd::cwd(); 236 chdir $dir 237 or die "Could not chdir to $dir: $!"; 238 my(@glob_files) = glob("a*{d[e]}j"); 239 chdir $cwd 240 or die "Could not chdir back to $cwd: $!"; 241 local $TODO = "home-made glob doesn't do regexes" if $^O eq 'VMS'; 242 is_deeply(\@glob_files, ['a_dej'], 243 "Got expected list: metacharacters and character class in pattern"); 244} 245 246# This used to segfault. 247my $i = bsd_glob('*', GLOB_ALTDIRFUNC); 248is(&File::Glob::GLOB_ERROR, 0, "Successfuly ignored unsupported flag"); 249 250package frimpy; # get away from the glob override, so we can test csh_glob, 251use Test::More; # which is perl's default 252 253# In case of PERL_EXTERNAL_GLOB: 254use subs 'glob'; 255BEGIN { *glob = \&File::Glob::csh_glob } 256 257is +(glob "a'b'")[0], (<a'b' c>)[0], "a'b' with and without spaces"; 258is <a"b">, 'ab', 'a"b" without spaces'; 259is_deeply [<a"b" c>], [qw<ab c>], 'a"b" without spaces'; 260is_deeply [<\\* .\\*>], [<\\*>,<.\\*>], 'backslashes with(out) spaces'; 261like <\\ >, qr/^\\? \z/, 'final escaped space'; 262is <a"b>, 'a"b', 'unmatched quote'; 263is < a"b >, 'a"b', 'unmatched quote with surrounding spaces'; 264is glob('a\"b'), 'a"b', '\ before quote *only* escapes quote'; 265is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote'; 266is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."'; 267is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'"; 268 269 270package bsdglob; # for testing the :bsd_glob export tag 271 272use File::Glob ':bsd_glob'; 273use Test::More; 274for (qw[ 275 GLOB_ABEND 276 GLOB_ALPHASORT 277 GLOB_ALTDIRFUNC 278 GLOB_BRACE 279 GLOB_CSH 280 GLOB_ERR 281 GLOB_ERROR 282 GLOB_LIMIT 283 GLOB_MARK 284 GLOB_NOCASE 285 GLOB_NOCHECK 286 GLOB_NOMAGIC 287 GLOB_NOSORT 288 GLOB_NOSPACE 289 GLOB_QUOTE 290 GLOB_TILDE 291 bsd_glob 292 ]) { 293 ok (exists &$_, qq':bsd_glob exports $_'); 294} 295is <a b>, 'a b', '<a b> under :bsd_glob'; 296is <"a" "b">, '"a" "b"', '<"a" "b"> under :bsd_glob'; 297is_deeply [<a b>], [q<a b>], '<> in list context under :bsd_glob'; 298