lib/Exporter.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 # Utility testing functions.
   9 my $test_num = 1;
  10 sub ok ($;$) {
  11     my($test, $name) = @_;
  12     print "not " unless $test;
  13     print "ok $test_num";
  14     print " - $name" if (defined $name && ! $^O eq 'VMS');
  15     print "\n";
  16     $test_num++;
  17 }
  18
  19
  20 my $loaded;
  21 BEGIN { $| = 1; $^W = 1; }
  22 END {print "not ok $test_num\n" unless $loaded;}
  23 print "1..$Total_tests\n";
  24 use Exporter;
  25 $loaded = 1;
  26 ok(1, 'compile');
  27
  28
  29 BEGIN {
  30     # Methods which Exporter says it implements.
  31     @Exporter_Methods = qw(import
  32                            export_to_level
  33                            require_version
  34                            export_fail
  35                           );
  36 }
  37
  38 BEGIN { $Total_tests = 14 + @Exporter_Methods }
  39
  40 package Testing;
  41 require Exporter;
  42 @ISA = qw(Exporter);
  43
  44 # Make sure Testing can do everything its supposed to.
  45 foreach my $meth (@::Exporter_Methods) {
  46     ::ok( Testing->can($meth), "subclass can $meth()" );
  47 }
  48
  49 %EXPORT_TAGS = (
  50                 This => [qw(stuff %left)],
  51                 That => [qw(Above the @wailing)],
  52                 tray => [qw(Fasten $seatbelt)],
  53                );
  54 @EXPORT    = qw(lifejacket);
  55 @EXPORT_OK = qw(under &your $seat);
  56 $VERSION = '1.05';
  57
  58 ::ok( Testing->require_version(1.05),   'require_version()' );
  59 eval { Testing->require_version(1.11); 1 };
  60 ::ok( $@,                               'require_version() fail' );
  61 ::ok( Testing->require_version(0),      'require_version(0)' );
  62
  63 sub lifejacket  { 'lifejacket'  }
  64 sub stuff       { 'stuff'       }
  65 sub Above       { 'Above'       }
  66 sub the         { 'the'         }
  67 sub Fasten      { 'Fasten'      }
  68 sub your        { 'your'        }
  69 sub under       { 'under'       }
  70 use vars qw($seatbelt $seat @wailing %left);
  71 $seatbelt = 'seatbelt';
  72 $seat     = 'seat';
  73 @wailing = qw(AHHHHHH);
  74 %left = ( left => "right" );
  75
  76
  77 Exporter::export_ok_tags;
  78
  79 my %tags     = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
  80 my %exportok = map { $_ => 1 } @EXPORT_OK;
  81 my $ok = 1;
  82 foreach my $tag (keys %tags) {
  83     $ok = exists $exportok{$tag};
  84 }
  85 ::ok( $ok, 'export_ok_tags()' );
  86
  87
  88 package Foo;
  89 Testing->import;
  90
  91 ::ok( defined &lifejacket,      'simple import' );
  92
  93
  94 package Bar;
  95 my @imports = qw($seatbelt &Above stuff @wailing %left);
  96 Testing->import(@imports);
  97
  98 ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
  99       'import by symbols' );
 100
 101
 102 package Yar;
 103 my @tags = qw(:This :tray);
 104 Testing->import(@tags);
 105
 106 ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
 107              map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
 108       'import by tags' );
 109
 110
 111 package Arrr;
 112 Testing->import(qw(!lifejacket));
 113
 114 ::ok( !defined &lifejacket,     'deny import by !' );
 115
 116
 117 package Mars;
 118 Testing->import('/e/');
 119
 120 ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
 121             grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
 122       'import by regex');
 123
 124
 125 package Venus;
 126 Testing->import('!/e/');
 127
 128 ::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
 129             grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
 130       'deny import by regex');
 131 ::ok( !defined &lifejacket, 'further denial' );
 132
 133
 134 package More::Testing;
 135 @ISA = qw(Exporter);
 136 $VERSION = 0;
 137 eval { More::Testing->require_version(0); 1 };
 138 ::ok(!$@,       'require_version(0) and $VERSION = 0');
 139
 140
 141 package Yet::More::Testing;
 142 @ISA = qw(Exporter);
 143 $VERSION = 0;
 144 eval { Yet::More::Testing->require_version(10); 1 };
 145 ::ok($@ !~ /\(undef\)/,       'require_version(10) and $VERSION = 0');