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 use Test::More tests => 20;
  13
  14 # override it in main::
  15 use File::DosGlob 'glob';
  16
  17 require Cwd;
  18
  19 my $expected;
  20 $expected = $_ = "op/a*.t";
  21 my @r = glob;
  22 is ($_, $expected, 'test if $_ takes as the default');
  23 cmp_ok(@r, '>=', 9) or diag("|@r|");
  24
  25 @r = <*/a*.t>;
  26 # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
  27 cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
  28 my $r = scalar @r;
  29
  30 @r = ();
  31 while (defined($_ = <*/a*.t>)) {
  32     print "# $_\n";
  33     push @r, $_;
  34 }
  35 is(scalar @r, $r, 'check scalar context');
  36
  37 @r = ();
  38 for (<*/a*.t>) {
  39     print "# $_\n";
  40     push @r, $_;
  41 }
  42 is(scalar @r, $r, 'check list context');
  43
  44 @r = ();
  45 while (<*/a*.t>) {
  46     print "# $_\n";
  47     push @r, $_;
  48 }
  49 is(scalar @r, $r, 'implicit assign to $_ in while()');
  50
  51 my @s = ();
  52 my $pat = '*/a*.t';
  53 while (glob ($pat)) {
  54     print "# $_\n";
  55     push @s, $_;
  56 }
  57 is("@r", "@s", 'explicit glob() gets assign magic too');
  58
  59 package Foo;
  60 use File::DosGlob 'glob';
  61 use Test::More;
  62 @s = ();
  63 $pat = '*/a*.t';
  64 while (glob($pat)) {
  65     print "# $_\n";
  66     push @s, $_;
  67 }
  68 is("@r", "@s", 'in a different package');
  69
  70 @s = ();
  71 while (<*/a*.t>) {
  72     my $i = 0;
  73     print "# $_ <";
  74     push @s, $_;
  75     while (<*/b*.t>) {
  76         print " $_";
  77         $i++;
  78     }
  79     print " >\n";
  80 }
  81 is("@r", "@s", 'different glob ops maintain independent contexts');
  82
  83 @s = ();
  84 eval <<'EOT';
  85 use File::DosGlob 'GLOBAL_glob';
  86 package Bar;
  87 while (<*/a*.t>) {
  88     my $i = 0;
  89     print "# $_ <";
  90     push @s, $_;
  91     while (glob '*/b*.t') {
  92         print " $_";
  93         $i++;
  94     }
  95     print " >\n";
  96 }
  97 EOT
  98 is("@r", "@s", 'global override');
  99
 100 # Test that a glob pattern containing ()'s works.
 101 # NB. The spaces in the glob patterns need to be backslash escaped.
 102 my $filename_containing_parens = "foo (123) bar";
 103 SKIP: {
 104     skip("can't create '$filename_containing_parens': $!", 9)
 105         unless open my $touch, ">", $filename_containing_parens;
 106     close $touch;
 107
 108     foreach my $pattern ("foo\\ (*", "*)\\ bar", "foo\\ (1*3)\\ bar") {
 109         @r = ();
 110         eval { @r = File::DosGlob::glob($pattern) };
 111         is($@, "", "eval for glob($pattern)");
 112         is(scalar @r, 1);
 113         is($r[0], $filename_containing_parens);
 114     }
 115
 116     1 while unlink $filename_containing_parens;
 117 }
 118
 119 # Test the globbing of a drive relative pattern such as "c:*.pl".
 120 # NB. previous versions of DosGlob inserted "./ after the drive letter to
 121 # make the expansion process work correctly. However, while it is harmless,
 122 # there is no reason for it to be in the result.
 123 my $cwd = Cwd::cwd();
 124 if ($cwd =~ /^([a-zA-Z]:)/) {
 125     my $drive = $1;
 126     @r = ();
 127     # This assumes we're in the "t" directory.
 128     eval { @r = File::DosGlob::glob("${drive}io/*.t") };
 129     ok(@r and !grep !m|^${drive}io/[^/]*\.t$|, @r);
 130 } else {
 131     pass();
 132 }