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