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