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;
  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 BEGIN {
  27     $test = 1;
  28     print "1..31\n";
  29     require Exporter;
  30     ok( 1, 'Exporter compiled' );
  31 }
  32
  33
  34 BEGIN {
  35     # Methods which Exporter says it implements.
  36     @Exporter_Methods = qw(import
  37                            export_to_level
  38                            require_version
  39                            export_fail
  40                           );
  41 }
  42
  43
  44 package Testing;
  45 require Exporter;
  46 @ISA = qw(Exporter);
  47
  48 # Make sure Testing can do everything its supposed to.
  49 foreach my $meth (@::Exporter_Methods) {
  50     ::ok( Testing->can($meth), "subclass can $meth()" );
  51 }
  52
  53 %EXPORT_TAGS = (
  54                 This => [qw(stuff %left)],
  55                 That => [qw(Above the @wailing)],
  56                 tray => [qw(Fasten $seatbelt)],
  57                );
  58 @EXPORT    = qw(lifejacket is);
  59 @EXPORT_OK = qw(under &your $seat);
  60 $VERSION = '1.05';
  61
  62 ::ok( Testing->require_version(1.05),   'require_version()' );
  63 eval { Testing->require_version(1.11); 1 };
  64 ::ok( $@,                               'require_version() fail' );
  65 ::ok( Testing->require_version(0),      'require_version(0)' );
  66
  67 sub lifejacket  { 'lifejacket'  }
  68 sub stuff       { 'stuff'       }
  69 sub Above       { 'Above'       }
  70 sub the         { 'the'         }
  71 sub Fasten      { 'Fasten'      }
  72 sub your        { 'your'        }
  73 sub under       { 'under'       }
  74 use vars qw($seatbelt $seat @wailing %left);
  75 $seatbelt = 'seatbelt';
  76 $seat     = 'seat';
  77 @wailing = qw(AHHHHHH);
  78 %left = ( left => "right" );
  79
  80 BEGIN {*is = \&Is};
  81 sub Is { 'Is' };
  82
  83 Exporter::export_ok_tags();
  84
  85 my %tags     = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
  86 my %exportok = map { $_ => 1 } @EXPORT_OK;
  87 my $ok = 1;
  88 foreach my $tag (keys %tags) {
  89     $ok = exists $exportok{$tag};
  90 }
  91 ::ok( $ok, 'export_ok_tags()' );
  92
  93
  94 package Foo;
  95 Testing->import;
  96
  97 ::ok( defined &lifejacket,      'simple import' );
  98
  99 my $got = eval {&lifejacket};
 100 ::ok ( $@ eq "", 'check we can call the imported subroutine')
 101   or print STDERR "# \$\@ is $@\n";
 102 ::ok ( $got eq 'lifejacket', 'and that it gave the correct result')
 103   or print STDERR "# expected 'lifejacket', got " .
 104   (defined $got ? "'$got'" : "undef") . "\n";
 105
 106 # The string eval is important. It stops $Foo::{is} existing when
 107 # Testing->import is called.
 108 ::ok( eval "defined &is",
 109       "Import a subroutine where exporter must create the typeglob" );
 110 $got = eval "&is";
 111 ::ok ( $@ eq "", 'check we can call the imported autoloaded subroutine')
 112   or chomp ($@), print STDERR "# \$\@ is $@\n";
 113 ::ok ( $got eq 'Is', 'and that it gave the correct result')
 114   or print STDERR "# expected 'Is', got " .
 115   (defined $got ? "'$got'" : "undef") . "\n";
 116
 117
 118 package Bar;
 119 my @imports = qw($seatbelt &Above stuff @wailing %left);
 120 Testing->import(@imports);
 121
 122 ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" }
 123          map  { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] }
 124             @imports),
 125     'import by symbols' );
 126
 127
 128 package Yar;
 129 my @tags = qw(:This :tray);
 130 Testing->import(@tags);
 131
 132 ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" }
 133          map  { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] }
 134          map  { @$_ }
 135             @{$Testing::EXPORT_TAGS{@tags}}),
 136     'import by tags' );
 137
 138
 139 package Arrr;
 140 Testing->import(qw(!lifejacket));
 141
 142 ::ok( !defined &lifejacket,     'deny import by !' );
 143
 144
 145 package Mars;
 146 Testing->import('/e/');
 147
 148 ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" }
 149          map  { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] }
 150          grep { /e/ }
 151             @Testing::EXPORT, @Testing::EXPORT_OK),
 152     'import by regex');
 153
 154
 155 package Venus;
 156 Testing->import('!/e/');
 157
 158 ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n == \\${s}Testing::$n" }
 159          map  { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] }
 160          grep { /e/ }
 161             @Testing::EXPORT, @Testing::EXPORT_OK),
 162     'deny import by regex');
 163
 164 ::ok( !defined &lifejacket, 'further denial' );
 165
 166
 167 package More::Testing;
 168 @ISA = qw(Exporter);
 169 $VERSION = 0;
 170 eval { More::Testing->require_version(0); 1 };
 171 ::ok(!$@,       'require_version(0) and $VERSION = 0');
 172
 173
 174 package Yet::More::Testing;
 175 @ISA = qw(Exporter);
 176 $VERSION = 0;
 177 eval { Yet::More::Testing->require_version(10); 1 };
 178 ::ok($@ !~ /\(undef\)/,       'require_version(10) and $VERSION = 0');
 179
 180
 181 my $warnings;
 182 BEGIN {
 183     local $SIG{__WARN__} = sub { $warnings = join '', @_ };
 184     package Testing::Unused::Vars;
 185     @ISA = qw(Exporter);
 186     @EXPORT = qw(this $TODO that);
 187
 188     package Foo;
 189     Testing::Unused::Vars->import;
 190 }
 191
 192 ::ok( !$warnings, 'Unused variables can be exported without warning' ) ||
 193   print "# $warnings\n";
 194
 195 package Moving::Target;
 196 @ISA = qw(Exporter);
 197 @EXPORT_OK = qw (foo);
 198
 199 sub foo {"This is foo"};
 200 sub bar {"This is bar"};
 201
 202 package Moving::Target::Test;
 203
 204 Moving::Target->import ('foo');
 205
 206 ::ok (foo() eq "This is foo", "imported foo before EXPORT_OK changed");
 207
 208 push @Moving::Target::EXPORT_OK, 'bar';
 209
 210 Moving::Target->import ('bar');
 211
 212 ::ok (bar() eq "This is bar", "imported bar after EXPORT_OK changed");
 213
 214 package The::Import;
 215
 216 use Exporter 'import';
 217
 218 ::ok(\&import == \&Exporter::import, "imported the import routine");
 219
 220 @EXPORT = qw( wibble );
 221 sub wibble {return "wobble"};
 222
 223 package Use::The::Import;
 224
 225 The::Import->import;
 226
 227 my $val = eval { wibble() };
 228 ::ok($val eq "wobble", "exported importer worked");
 229
 230 # Check that Carp recognizes Exporter as internal to Perl
 231 require Carp;
 232 eval { Carp::croak() };
 233 ::ok($Carp::Internal{Exporter}, "Carp recognizes Exporter");
 234 ::ok($Carp::Internal{'Exporter::Heavy'}, "Carp recognizes Exporter::Heavy");
 235
 236 package Exporter::for::Tied::_;
 237
 238 @ISA = 'Exporter';
 239 @EXPORT = 'foo';
 240
 241 package Tied::_;
 242
 243 sub TIESCALAR{bless[]}
 244 # no tie methods!
 245
 246 {
 247  tie my $t, __PACKAGE__;
 248  for($t) { # $_ is now tied
 249   import Exporter::for::Tied::_;
 250  }
 251 }
 252 ::ok(1, 'import with tied $_');