lib/Exporter.t

   1 #!perl -w
   2
   3 BEGIN {
   4    if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8 }
   9
  10 # Can't use Test::Simple/More, they depend on Exporter.
  11 my $test = 1;
  12 sub ok ($;$) {
  13     my($ok, $name) = @_;
  14
  15     # You have to do it this way or VMS will get confused.
  16     printf "%sok %d%s\n", ($ok ? '' : 'not '), $test,
  17       (defined $name ? " - $name" : '');
  18
  19     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  20
  21     $test++;
  22     return $ok;
  23 }
  24
  25
  26 print "1..28\n";
  27 require Exporter;
  28 ok( 1, 'Exporter compiled' );
  29
  30
  31 BEGIN {
  32     # Methods which Exporter says it implements.
  33     @Exporter_Methods = qw(import
  34                            export_to_level
  35                            require_version
  36                            export_fail
  37                           );
  38 }
  39
  40
  41 package Testing;
  42 require Exporter;
  43 @ISA = qw(Exporter);
  44
  45 # Make sure Testing can do everything its supposed to.
  46 foreach my $meth (@::Exporter_Methods) {
  47     ::ok( Testing->can($meth), "subclass can $meth()" );
  48 }
  49
  50 %EXPORT_TAGS = (
  51                 This => [qw(stuff %left)],
  52                 That => [qw(Above the @wailing)],
  53                 tray => [qw(Fasten $seatbelt)],
  54                );
  55 @EXPORT    = qw(lifejacket is);
  56 @EXPORT_OK = qw(under &your $seat);
  57 $VERSION = '1.05';
  58
  59 ::ok( Testing->require_version(1.05),   'require_version()' );
  60 eval { Testing->require_version(1.11); 1 };
  61 ::ok( $@,                               'require_version() fail' );
  62 ::ok( Testing->require_version(0),      'require_version(0)' );
  63
  64 sub lifejacket  { 'lifejacket'  }
  65 sub stuff       { 'stuff'       }
  66 sub Above       { 'Above'       }
  67 sub the         { 'the'         }
  68 sub Fasten      { 'Fasten'      }
  69 sub your        { 'your'        }
  70 sub under       { 'under'       }
  71 use vars qw($seatbelt $seat @wailing %left);
  72 $seatbelt = 'seatbelt';
  73 $seat     = 'seat';
  74 @wailing = qw(AHHHHHH);
  75 %left = ( left => "right" );
  76
  77 BEGIN {*is = \&Is};
  78 sub Is { 'Is' };
  79
  80 Exporter::export_ok_tags();
  81
  82 my %tags     = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
  83 my %exportok = map { $_ => 1 } @EXPORT_OK;
  84 my $ok = 1;
  85 foreach my $tag (keys %tags) {
  86     $ok = exists $exportok{$tag};
  87 }
  88 ::ok( $ok, 'export_ok_tags()' );
  89
  90
  91 package Foo;
  92 Testing->import;
  93
  94 ::ok( defined &lifejacket,      'simple import' );
  95
  96 my $got = eval {&lifejacket};
  97 ::ok ( $@ eq "", 'check we can call the imported subroutine')
  98   or print STDERR "# \$\@ is $@\n";
  99 ::ok ( $got eq 'lifejacket', 'and that it gave the correct result')
 100   or print STDERR "# expected 'lifejacket', got " .
 101   (defined $got ? "'$got'" : "undef") . "\n";
 102
 103 # The string eval is important. It stops $Foo::{is} existing when
 104 # Testing->import is called.
 105 ::ok( eval "defined &is",
 106       "Import a subroutine where exporter must create the typeglob" );
 107 $got = eval "&is";
 108 ::ok ( $@ eq "", 'check we can call the imported autoloaded subroutine')
 109   or chomp ($@), print STDERR "# \$\@ is $@\n";
 110 ::ok ( $got eq 'Is', 'and that it gave the correct result')
 111   or print STDERR "# expected 'Is', got " .
 112   (defined $got ? "'$got'" : "undef") . "\n";
 113
 114
 115 package Bar;
 116 my @imports = qw($seatbelt &Above stuff @wailing %left);
 117 Testing->import(@imports);
 118
 119 ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
 120       'import by symbols' );
 121
 122
 123 package Yar;
 124 my @tags = qw(:This :tray);
 125 Testing->import(@tags);
 126
 127 ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
 128              map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
 129       'import by tags' );
 130
 131
 132 package Arrr;
 133 Testing->import(qw(!lifejacket));
 134
 135 ::ok( !defined &lifejacket,     'deny import by !' );
 136
 137
 138 package Mars;
 139 Testing->import('/e/');
 140
 141 ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
 142             grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
 143       'import by regex');
 144
 145
 146 package Venus;
 147 Testing->import('!/e/');
 148
 149 ::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
 150             grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
 151       'deny import by regex');
 152 ::ok( !defined &lifejacket, 'further denial' );
 153
 154
 155 package More::Testing;
 156 @ISA = qw(Exporter);
 157 $VERSION = 0;
 158 eval { More::Testing->require_version(0); 1 };
 159 ::ok(!$@,       'require_version(0) and $VERSION = 0');
 160
 161
 162 package Yet::More::Testing;
 163 @ISA = qw(Exporter);
 164 $VERSION = 0;
 165 eval { Yet::More::Testing->require_version(10); 1 };
 166 ::ok($@ !~ /\(undef\)/,       'require_version(10) and $VERSION = 0');
 167
 168
 169 my $warnings;
 170 BEGIN {
 171     $SIG{__WARN__} = sub { $warnings = join '', @_ };
 172     package Testing::Unused::Vars;
 173     @ISA = qw(Exporter);
 174     @EXPORT = qw(this $TODO that);
 175
 176     package Foo;
 177     Testing::Unused::Vars->import;
 178 }
 179
 180 ::ok( !$warnings, 'Unused variables can be exported without warning' ) ||
 181   print "# $warnings\n";
 182
 183 package Moving::Target;
 184 @ISA = qw(Exporter);
 185 @EXPORT_OK = qw (foo);
 186
 187 sub foo {"This is foo"};
 188 sub bar {"This is bar"};
 189
 190 package Moving::Target::Test;
 191
 192 Moving::Target->import ('foo');
 193
 194 ::ok (foo() eq "This is foo", "imported foo before EXPORT_OK changed");
 195
 196 push @Moving::Target::EXPORT_OK, 'bar';
 197
 198 Moving::Target->import ('bar');
 199
 200 ::ok (bar() eq "This is bar", "imported bar after EXPORT_OK changed");
 201
 202 package The::Import;
 203
 204 use Exporter 'import';
 205
 206 eval { import() };
 207 ::ok(\&import == \&Exporter::import, "imported the import routine");
 208
 209 @EXPORT = qw( wibble );
 210 sub wibble {return "wobble"};
 211
 212 package Use::The::Import;
 213
 214 The::Import->import;
 215
 216 my $val = eval { wibble() };
 217 ::ok($val eq "wobble", "exported importer worked");
 218