dist/Exporter/t/Exporter.t

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