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'; 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 '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 162map { $_ =~ s/test\.?/TEST/i } @a if $^O eq 'VMS'; 163print "# @a\n"; 164 165is_deeply(\@a, ['TEST', 'a', 'b']); 166 167# "~" should expand to $ENV{HOME} 168{ 169 local $ENV{HOME} = "sweet home"; 170 @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); 171 is_deeply(\@a, [$ENV{HOME}]); 172} 173 174# GLOB_ALPHASORT (default) should sort alphabetically regardless of case 175mkdir "pteerslo", 0777; 176chdir "pteerslo"; 177 178my @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); 179my @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); 180if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER 181 @f_names = sort(@f_names); 182} 183if ($^O eq 'VMS') { # VMS is happily caseignorant 184 @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); 185 @f_names = @f_alpha; 186} 187 188for (@f_names) { 189 open T, "> $_"; 190 close T; 191} 192 193my $pat = "*.pl"; 194 195my @g_names = bsd_glob($pat, 0); 196print "# f_names = @f_names\n"; 197print "# g_names = @g_names\n"; 198is_deeply(\@g_names, \@f_names); 199 200my @g_alpha = bsd_glob($pat); 201print "# f_alpha = @f_alpha\n"; 202print "# g_alpha = @g_alpha\n"; 203is_deeply(\@g_alpha, \@f_alpha); 204 205unlink @f_names; 206chdir ".."; 207rmdir "pteerslo"; 208 209# this can panic if PL_glob_index gets passed as flags to bsd_glob 210<*>; <*>; 211pass("Don't panic"); 212 213{ 214 use File::Temp qw(tempdir); 215 use File::Spec qw(); 216 217 my($dir) = tempdir(CLEANUP => 1) 218 or die "Could not create temporary directory"; 219 for my $file (qw(a_dej a_ghj a_qej)) { 220 open my $fh, ">", File::Spec->catfile($dir, $file) 221 or die "Could not create file $dir/$file: $!"; 222 close $fh; 223 } 224 my $cwd = Cwd::cwd(); 225 chdir $dir 226 or die "Could not chdir to $dir: $!"; 227 my(@glob_files) = glob("a*{d[e]}j"); 228 chdir $cwd 229 or die "Could not chdir back to $cwd: $!"; 230 local $TODO = "home-made glob doesn't do regexes" if $^O eq 'VMS'; 231 is_deeply(\@glob_files, ['a_dej']); 232} 233 234# This used to segfault. 235my $i = bsd_glob('*', GLOB_ALTDIRFUNC); 236is(&File::Glob::GLOB_ERROR, 0, "Successfuly ignored unsupported flag"); 237 238package frimpy; # get away from the glob override, so we can test csh_glob, 239use Test::More; # which is perl's default 240 241# In case of PERL_EXTERNAL_GLOB: 242use subs 'glob'; 243BEGIN { *glob = \&File::Glob::csh_glob } 244 245is +(glob "a'b'")[0], (<a'b' c>)[0], "a'b' with and without spaces"; 246is <a"b">, 'ab', 'a"b" without spaces'; 247is_deeply [<a"b" c>], [qw<ab c>], 'a"b" without spaces'; 248is_deeply [<\\* .\\*>], [<\\*>,<.\\*>], 'backslashes with(out) spaces'; 249like <\\ >, qr/^\\? \z/, 'final escaped space'; 250is <a"b>, 'a"b', 'unmatched quote'; 251is < a"b >, 'a"b', 'unmatched quote with surrounding spaces'; 252is glob('a\"b'), 'a"b', '\ before quote *only* escapes quote'; 253is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote'; 254is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."'; 255is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'"; 256 257 258package bsdglob; # for testing the :bsd_glob export tag 259 260use File::Glob ':bsd_glob'; 261use Test::More; 262for (qw[ 263 GLOB_ABEND 264 GLOB_ALPHASORT 265 GLOB_ALTDIRFUNC 266 GLOB_BRACE 267 GLOB_CSH 268 GLOB_ERR 269 GLOB_ERROR 270 GLOB_LIMIT 271 GLOB_MARK 272 GLOB_NOCASE 273 GLOB_NOCHECK 274 GLOB_NOMAGIC 275 GLOB_NOSORT 276 GLOB_NOSPACE 277 GLOB_QUOTE 278 GLOB_TILDE 279 bsd_glob 280 ]) { 281 ok (exists &$_, qq':bsd_glob exports $_'); 282} 283is <a b>, 'a b', '<a b> under :bsd_glob'; 284is <"a" "b">, '"a" "b"', '<"a" "b"> under :bsd_glob'; 285is_deeply [<a b>], [q<a b>], '<> in list context under :bsd_glob'; 286