t/lib/glob-global.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     unshift @INC, '../lib';
   6
   7     print "1..10\n";
   8 }
   9 END {
  10     print "not ok 1\n" unless $loaded;
  11 }
  12
  13 BEGIN {
  14     *CORE::GLOBAL::glob = sub { "Just another Perl hacker," };
  15 }
  16
  17 BEGIN {
  18     if ("Just another Perl hacker," ne (<*>)[0]) {
  19         die <<EOMessage;
  20 Your version of perl ($]) doesn't seem to allow extensions to override
  21 the core glob operator.
  22 EOMessage
  23     }
  24 }
  25
  26 use File::Glob 'globally';
  27 $loaded = 1;
  28 print "ok 1\n";
  29
  30 $_ = "lib/*.t";
  31 my @r = glob;
  32 print "not " if $_ ne 'lib/*.t';
  33 print "ok 2\n";
  34
  35 # we should have at least basic.t, global.t, taint.t
  36 print "# |@r|\nnot " if @r < 3;
  37 print "ok 3\n";
  38
  39 # check if <*/*> works
  40 @r = <*/*.t>;
  41 # at least t/global.t t/basic.t, t/taint.t
  42 print "not " if @r < 3;
  43 print "ok 4\n";
  44 my $r = scalar @r;
  45
  46 # check if scalar context works
  47 @r = ();
  48 while (defined($_ = <*/*.t>)) {
  49     #print "# $_\n";
  50     push @r, $_;
  51 }
  52 print "not " if @r != $r;
  53 print "ok 5\n";
  54
  55 # check if array context works
  56 @r = ();
  57 for (<*/*.t>) {
  58     #print "# $_\n";
  59     push @r, $_;
  60 }
  61 print "not " if @r != $r;
  62 print "ok 6\n";
  63
  64 # test if implicit assign to $_ in while() works
  65 @r = ();
  66 while (<*/*.t>) {
  67     #print "# $_\n";
  68     push @r, $_;
  69 }
  70 print "not " if @r != $r;
  71 print "ok 7\n";
  72
  73 # test if explicit glob() gets assign magic too
  74 my @s = ();
  75 while (glob '*/*.t') {
  76     #print "# $_\n";
  77     push @s, $_;
  78 }
  79 print "not " if "@r" ne "@s";
  80 print "ok 8\n";
  81
  82 # how about in a different package, like?
  83 package Foo;
  84 use File::Glob 'globally';
  85 @s = ();
  86 while (glob '*/*.t') {
  87     #print "# $_\n";
  88     push @s, $_;
  89 }
  90 print "not " if "@r" ne "@s";
  91 print "ok 9\n";
  92
  93 # test if different glob ops maintain independent contexts
  94 @s = ();
  95 my $i = 0;
  96 while (<*/*.t>) {
  97     #print "# $_ <";
  98     push @s, $_;
  99     while (<bas*/*.t>) {
 100         #print " $_";
 101         $i++;
 102     }
 103     #print " >\n";
 104 }
 105 print "not " if "@r" ne "@s" or not $i;
 106 print "ok 10\n";