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..10\n";
  13
  14 # override it in main::
  15 use File::DosGlob 'glob';
  16
  17 # test if $_ takes as the default
  18 my $expected;
  19 if ($^O eq 'MacOS') {
  20     $expected = $_ = ":op:a*.t";
  21 } else {
  22     $expected = $_ = "op/a*.t";
  23 }
  24 $_ = "op/a*.t";
  25 my @r = glob;
  26 print "not " if $_ ne $expected;
  27 print "ok 1\n";
  28 print "# |@r|\nnot " if @r < 9;
  29 print "ok 2\n";
  30
  31 # check if <*/*> works
  32 if ($^O eq 'MacOS') {
  33     @r = <:*:a*.t>;
  34 } else {
  35     @r = <*/a*.t>;
  36 }
  37 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
  38 print "# |@r|\nnot " if @r < 9;
  39 print "ok 3\n";
  40 my $r = scalar @r;
  41
  42 # check if scalar context works
  43 @r = ();
  44 while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) {
  45     print "# $_\n";
  46     push @r, $_;
  47 }
  48 print "not " if @r != $r;
  49 print "ok 4\n";
  50
  51 # check if list context works
  52 @r = ();
  53 if ($^O eq 'MacOS') {
  54     for (<:*:a*.t>) {
  55         print "# $_\n";
  56         push @r, $_;
  57     }
  58 } else {
  59     for (<*/a*.t>) {
  60         print "# $_\n";
  61         push @r, $_;
  62     }
  63 }
  64 print "not " if @r != $r;
  65 print "ok 5\n";
  66
  67 # test if implicit assign to $_ in while() works
  68 @r = ();
  69 if ($^O eq 'MacOS') {
  70     while (<:*:a*.t>) {
  71         print "# $_\n";
  72         push @r, $_;
  73     }
  74 } else {
  75     while (<*/a*.t>) {
  76         print "# $_\n";
  77         push @r, $_;
  78     }
  79 }
  80 print "not " if @r != $r;
  81 print "ok 6\n";
  82
  83 # test if explicit glob() gets assign magic too
  84 my @s = ();
  85 my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t';
  86 while (glob ($pat)) {
  87     print "# $_\n";
  88     push @s, $_;
  89 }
  90 print "not " if "@r" ne "@s";
  91 print "ok 7\n";
  92
  93 # how about in a different package, like?
  94 package Foo;
  95 use File::DosGlob 'glob';
  96 @s = ();
  97 while (glob '*/a*.t') {
  98     print "# $_\n";
  99     push @s, $_;
 100 }
 101 print "not " if "@r" ne "@s";
 102 print "ok 8\n";
 103
 104 # test if different glob ops maintain independent contexts
 105 @s = ();
 106 while (<*/a*.t>) {
 107     my $i = 0;
 108     print "# $_ <";
 109     push @s, $_;
 110     while (<*/b*.t>) {
 111         print " $_";
 112         $i++;
 113     }
 114     print " >\n";
 115 }
 116 print "not " if "@r" ne "@s";
 117 print "ok 9\n";
 118
 119 # how about a global override, hm?
 120 eval <<'EOT';
 121 use File::DosGlob 'GLOBAL_glob';
 122 package Bar;
 123 @s = ();
 124 while (<*/a*.t>) {
 125     my $i = 0;
 126     print "# $_ <";
 127     push @s, $_;
 128     while (glob '*/b*.t') {
 129         print " $_";
 130         $i++;
 131     }
 132     print " >\n";
 133 }
 134 print "not " if "@r" ne "@s";
 135 print "ok 10\n";
 136 EOT