lib/File/DosGlob.t

   1 #!./perl
   2
   3 #
   4 # test glob() in File::DosGlob
   5 #
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     @INC = '../lib';
  10 }
  11
  12 print "1..17\n";
  13
  14 # override it in main::
  15 use File::DosGlob 'glob';
  16
  17 require Cwd;
  18
  19 # test if $_ takes as the default
  20 my $expected;
  21 if ($^O eq 'MacOS') {
  22     $expected = $_ = ":op:a*.t";
  23 } else {
  24     $expected = $_ = "op/a*.t";
  25 }
  26 my @r = glob;
  27 print "not " if $_ ne $expected;
  28 print "ok 1\n";
  29 print "# |@r|\nnot " if @r < 9;
  30 print "ok 2\n";
  31
  32 # check if <*/*> works
  33 if ($^O eq 'MacOS') {
  34     @r = <:*:a*.t>;
  35 } else {
  36     @r = <*/a*.t>;
  37 }
  38 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
  39 print "# |@r|\nnot " if @r < 9;
  40 print "ok 3\n";
  41 my $r = scalar @r;
  42
  43 # check if scalar context works
  44 @r = ();
  45 while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) {
  46     print "# $_\n";
  47     push @r, $_;
  48 }
  49 print "not " if @r != $r;
  50 print "ok 4\n";
  51
  52 # check if list context works
  53 @r = ();
  54 if ($^O eq 'MacOS') {
  55     for (<:*:a*.t>) {
  56         print "# $_\n";
  57         push @r, $_;
  58     }
  59 } else {
  60     for (<*/a*.t>) {
  61         print "# $_\n";
  62         push @r, $_;
  63     }
  64 }
  65 print "not " if @r != $r;
  66 print "ok 5\n";
  67
  68 # test if implicit assign to $_ in while() works
  69 @r = ();
  70 if ($^O eq 'MacOS') {
  71     while (<:*:a*.t>) {
  72         print "# $_\n";
  73         push @r, $_;
  74     }
  75 } else {
  76     while (<*/a*.t>) {
  77         print "# $_\n";
  78         push @r, $_;
  79     }
  80 }
  81 print "not " if @r != $r;
  82 print "ok 6\n";
  83
  84 # test if explicit glob() gets assign magic too
  85 my @s = ();
  86 my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t';
  87 while (glob ($pat)) {
  88     print "# $_\n";
  89     push @s, $_;
  90 }
  91 print "not " if "@r" ne "@s";
  92 print "ok 7\n";
  93
  94 # how about in a different package, like?
  95 package Foo;
  96 use File::DosGlob 'glob';
  97 @s = ();
  98 $pat = $^O eq 'MacOS' ? ':*:a*.t' : '*/a*.t';
  99 while (glob($pat)) {
 100     print "# $_\n";
 101     push @s, $_;
 102 }
 103 print "not " if "@r" ne "@s";
 104 print "ok 8\n";
 105
 106 # test if different glob ops maintain independent contexts
 107 @s = ();
 108 if ($^O eq 'MacOS') {
 109     while (<:*:a*.t>) {
 110         my $i = 0;
 111         print "# $_ <";
 112         push @s, $_;
 113         while (<:*:b*.t>) {
 114             print " $_";
 115             $i++;
 116         }
 117         print " >\n";
 118     }
 119 } else {
 120     while (<*/a*.t>) {
 121         my $i = 0;
 122         print "# $_ <";
 123         push @s, $_;
 124         while (<*/b*.t>) {
 125             print " $_";
 126             $i++;
 127         }
 128         print " >\n";
 129     }
 130 }
 131 print "not " if "@r" ne "@s";
 132 print "ok 9\n";
 133
 134 # how about a global override, hm?
 135 eval <<'EOT';
 136 use File::DosGlob 'GLOBAL_glob';
 137 package Bar;
 138 @s = ();
 139 if ($^O eq 'MacOS') {
 140     while (<:*:a*.t>) {
 141         my $i = 0;
 142         print "# $_ <";
 143         push @s, $_;
 144         while (glob ':*:b*.t') {
 145             print " $_";
 146             $i++;
 147         }
 148         print " >\n";
 149     }
 150 } else {
 151     while (<*/a*.t>) {
 152         my $i = 0;
 153         print "# $_ <";
 154         push @s, $_;
 155         while (glob '*/b*.t') {
 156             print " $_";
 157             $i++;
 158         }
 159         print " >\n";
 160     }
 161 }
 162 print "not " if "@r" ne "@s";
 163 print "ok 10\n";
 164 EOT
 165
 166 # Test that a glob pattern containing ()'s works.
 167 # NB. The spaces in the glob patterns need to be backslash escaped.
 168 my $filename_containing_parens = "foo (123) bar";
 169 if (open(TOUCH, ">", $filename_containing_parens)) {
 170     close(TOUCH);
 171
 172     @r = ();
 173     eval { @r = File::DosGlob::glob("foo\\ (*") };
 174     print +($@ ? "not " : ""), "ok 11\n";
 175     print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
 176     print "ok 12\n";
 177
 178     @r = ();
 179     eval { @r = File::DosGlob::glob("*)\\ bar") };
 180     print +($@ ? "not " : ""), "ok 13\n";
 181     print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
 182     print "ok 14\n";
 183
 184     @r = ();
 185     eval { @r = File::DosGlob::glob("foo\\ (1*3)\\ bar") };
 186     print +($@ ? "not " : ""), "ok 15\n";
 187     print "not " unless (@r == 1 and $r[0] eq $filename_containing_parens);
 188     print "ok 16\n";
 189
 190     1 while unlink $filename_containing_parens;
 191 }
 192 else {
 193     for (11..16) {
 194         print "ok $_ # skip - can't create '$filename_containing_parens': $!\n";
 195     }
 196 }
 197
 198 # Test the globbing of a drive relative pattern such as "c:*.pl".
 199 # NB. previous versions of DosGlob inserted "./ after the drive letter to
 200 # make the expansion process work correctly. However, while it is harmless,
 201 # there is no reason for it to be in the result.
 202 my $cwd = Cwd::cwd();
 203 if ($cwd =~ /^([a-zA-Z]:)/) {
 204     my $drive = $1;
 205     @r = ();
 206     # This assumes we're in the "t" directory.
 207     eval { @r = File::DosGlob::glob("${drive}io/*.t") };
 208     print +((@r and !grep !m|^${drive}io/[^/]*\.t$|, @r) ? "" : "not "), "ok 17\n";
 209 } else {
 210     print "ok 17\n";
 211 }