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 my @r = glob;
  25 print "not " if $_ ne $expected;
  26 print "ok 1\n";
  27 print "# |@r|\nnot " if @r < 9;
  28 print "ok 2\n";
  29
  30 # check if <*/*> works
  31 if ($^O eq 'MacOS') {
  32     @r = <:*:a*.t>;
  33 } else {
  34     @r = <*/a*.t>;
  35 }
  36 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
  37 print "# |@r|\nnot " if @r < 9;
  38 print "ok 3\n";
  39 my $r = scalar @r;
  40
  41 # check if scalar context works
  42 @r = ();
  43 while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) {
  44     print "# $_\n";
  45     push @r, $_;
  46 }
  47 print "not " if @r != $r;
  48 print "ok 4\n";
  49
  50 # check if list context works
  51 @r = ();
  52 if ($^O eq 'MacOS') {
  53     for (<:*:a*.t>) {
  54         print "# $_\n";
  55         push @r, $_;
  56     }
  57 } else {
  58     for (<*/a*.t>) {
  59         print "# $_\n";
  60         push @r, $_;
  61     }
  62 }
  63 print "not " if @r != $r;
  64 print "ok 5\n";
  65
  66 # test if implicit assign to $_ in while() works
  67 @r = ();
  68 if ($^O eq 'MacOS') {
  69     while (<:*:a*.t>) {
  70         print "# $_\n";
  71         push @r, $_;
  72     }
  73 } else {
  74     while (<*/a*.t>) {
  75         print "# $_\n";
  76         push @r, $_;
  77     }
  78 }
  79 print "not " if @r != $r;
  80 print "ok 6\n";
  81
  82 # test if explicit glob() gets assign magic too
  83 my @s = ();
  84 my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t';
  85 while (glob ($pat)) {
  86     print "# $_\n";
  87     push @s, $_;
  88 }
  89 print "not " if "@r" ne "@s";
  90 print "ok 7\n";
  91
  92 # how about in a different package, like?
  93 package Foo;
  94 use File::DosGlob 'glob';
  95 @s = ();
  96 $pat = $^O eq 'MacOS' ? ':*:a*.t' : '*/a*.t';
  97 while (glob($pat)) {
  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 if ($^O eq 'MacOS') {
 107     while (<:*:a*.t>) {
 108         my $i = 0;
 109         print "# $_ <";
 110         push @s, $_;
 111         while (<:*:b*.t>) {
 112             print " $_";
 113             $i++;
 114         }
 115         print " >\n";
 116     }
 117 } else {
 118     while (<*/a*.t>) {
 119         my $i = 0;
 120         print "# $_ <";
 121         push @s, $_;
 122         while (<*/b*.t>) {
 123             print " $_";
 124             $i++;
 125         }
 126         print " >\n";
 127     }
 128 }
 129 print "not " if "@r" ne "@s";
 130 print "ok 9\n";
 131
 132 # how about a global override, hm?
 133 eval <<'EOT';
 134 use File::DosGlob 'GLOBAL_glob';
 135 package Bar;
 136 @s = ();
 137 if ($^O eq 'MacOS') {
 138     while (<:*:a*.t>) {
 139         my $i = 0;
 140         print "# $_ <";
 141         push @s, $_;
 142         while (glob ':*:b*.t') {
 143             print " $_";
 144             $i++;
 145         }
 146         print " >\n";
 147     }
 148 } else {
 149     while (<*/a*.t>) {
 150         my $i = 0;
 151         print "# $_ <";
 152         push @s, $_;
 153         while (glob '*/b*.t') {
 154             print " $_";
 155             $i++;
 156         }
 157         print " >\n";
 158     }
 159 }
 160 print "not " if "@r" ne "@s";
 161 print "ok 10\n";
 162 EOT