| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 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 | print "1..11\n"; |
| 12 | } |
| 13 | END { |
| 14 | print "not ok 1\n" unless $loaded; |
| 15 | } |
| 16 | use File::Glob ':glob'; |
| 17 | use Cwd (); |
| 18 | $loaded = 1; |
| 19 | print "ok 1\n"; |
| 20 | |
| 21 | sub array { |
| 22 | return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; |
| 23 | } |
| 24 | |
| 25 | # look for the contents of the current directory |
| 26 | $ENV{PATH} = "/bin"; |
| 27 | delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; |
| 28 | @correct = (); |
| 29 | if (opendir(D, ".")) { |
| 30 | @correct = grep { !/^\./ } sort readdir(D); |
| 31 | closedir D; |
| 32 | } |
| 33 | @a = File::Glob::glob("*", 0); |
| 34 | @a = sort @a; |
| 35 | if ("@a" ne "@correct" || GLOB_ERROR) { |
| 36 | print "# |@a| ne |@correct|\nnot "; |
| 37 | } |
| 38 | print "ok 2\n"; |
| 39 | |
| 40 | # look up the user's home directory |
| 41 | # should return a list with one item, and not set ERROR |
| 42 | if ($^O ne 'MSWin32' && $^O ne 'VMS') { |
| 43 | eval { |
| 44 | ($name, $home) = (getpwuid($>))[0,7]; |
| 45 | 1; |
| 46 | } and do { |
| 47 | @a = bsd_glob("~$name", GLOB_TILDE); |
| 48 | if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { |
| 49 | print "not "; |
| 50 | } |
| 51 | }; |
| 52 | } |
| 53 | print "ok 3\n"; |
| 54 | |
| 55 | # check backslashing |
| 56 | # should return a list with one item, and not set ERROR |
| 57 | @a = bsd_glob('TEST', GLOB_QUOTE); |
| 58 | if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { |
| 59 | local $/ = "]["; |
| 60 | print "# [@a]\n"; |
| 61 | print "not "; |
| 62 | } |
| 63 | print "ok 4\n"; |
| 64 | |
| 65 | # check nonexistent checks |
| 66 | # should return an empty list |
| 67 | # XXX since errfunc is NULL on win32, this test is not valid there |
| 68 | @a = bsd_glob("asdfasdf", 0); |
| 69 | if ($^O ne 'MSWin32' and scalar @a != 0) { |
| 70 | print "# |@a|\nnot "; |
| 71 | } |
| 72 | print "ok 5\n"; |
| 73 | |
| 74 | # check bad protections |
| 75 | # should return an empty list, and set ERROR |
| 76 | if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' |
| 77 | or $^O eq 'cygwin' or Cwd::cwd() =~ m#^/afs#s or not $>) |
| 78 | { |
| 79 | print "ok 6 # skipped\n"; |
| 80 | } |
| 81 | else { |
| 82 | $dir = "pteerslt"; |
| 83 | mkdir $dir, 0; |
| 84 | @a = bsd_glob("$dir/*", GLOB_ERR); |
| 85 | #print "\@a = ", array(@a); |
| 86 | rmdir $dir; |
| 87 | if (scalar(@a) != 0 || GLOB_ERROR == 0) { |
| 88 | print "not "; |
| 89 | } |
| 90 | print "ok 6\n"; |
| 91 | } |
| 92 | |
| 93 | # check for csh style globbing |
| 94 | @a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); |
| 95 | unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { |
| 96 | print "not "; |
| 97 | } |
| 98 | print "ok 7\n"; |
| 99 | |
| 100 | @a = bsd_glob( |
| 101 | '{TES*,doesntexist*,a,b}', |
| 102 | GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) |
| 103 | ); |
| 104 | |
| 105 | # Working on t/TEST often causes this test to fail because it sees Emacs temp |
| 106 | # and RCS files. Filter them out, and .pm files too, and patch temp files. |
| 107 | @a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; |
| 108 | |
| 109 | print "# @a\n"; |
| 110 | |
| 111 | unless (@a == 3 |
| 112 | and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') |
| 113 | and $a[1] eq 'a' |
| 114 | and $a[2] eq 'b') |
| 115 | { |
| 116 | print "not "; |
| 117 | } |
| 118 | print "ok 8\n"; |
| 119 | |
| 120 | # "~" should expand to $ENV{HOME} |
| 121 | $ENV{HOME} = "sweet home"; |
| 122 | @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); |
| 123 | unless (@a == 1 and $a[0] eq $ENV{HOME}) { |
| 124 | print "not "; |
| 125 | } |
| 126 | print "ok 9\n"; |
| 127 | |
| 128 | # GLOB_ALPHASORT (default) should sort alphabetically regardless of case |
| 129 | mkdir "pteerslt", 0777; |
| 130 | chdir "pteerslt"; |
| 131 | @f_ascii = qw(A.test B.test C.test a.test b.test c.test); |
| 132 | @f_alpha = qw(A.test a.test B.test b.test C.test c.test); |
| 133 | if (ord('A') == 193) { # EBCDIC char sets sort lower case before UPPER |
| 134 | @f_ascii = sort(@f_ascii); |
| 135 | @f_alpha = qw(a.test A.test b.test B.test c.test C.test); |
| 136 | } |
| 137 | for (@f_ascii) { |
| 138 | open T, "> $_"; |
| 139 | close T; |
| 140 | } |
| 141 | $pat = "*.test"; |
| 142 | $ok = 1; |
| 143 | @g_ascii = bsd_glob($pat, 0); |
| 144 | print "# f_ascii = @f_ascii\n"; |
| 145 | print "# g_ascii = @g_ascii\n"; |
| 146 | if (@g_ascii == 6) { |
| 147 | for (@f_ascii) { |
| 148 | $ok = 0 unless $_ eq shift @g_ascii; |
| 149 | } |
| 150 | } |
| 151 | print $ok ? "ok 10\n" : "not ok 10\n"; |
| 152 | $ok = 1; |
| 153 | @g_alpha = bsd_glob($pat); |
| 154 | print "# f_alpha = @f_alpha\n"; |
| 155 | print "# g_alpha = @g_alpha\n"; |
| 156 | if (@g_ascii == 6) { |
| 157 | for (@f_alpha) { |
| 158 | $ok = 0 unless $_ eq shift @g_alpha; |
| 159 | } |
| 160 | } |
| 161 | print $ok ? "ok 11\n" : "not ok 11\n"; |
| 162 | unlink @f_ascii; |
| 163 | chdir ".."; |
| 164 | rmdir "pteerslt"; |