1#!perl -w 2 3# Can't use Test::Simple/More, they depend on Exporter. 4my $test; 5sub 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 19BEGIN { 20 $test = 1; 21 print "1..33\n"; 22 require Exporter; 23 ok( 1, 'Exporter compiled' ); 24} 25 26 27BEGIN { 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 37package Testing; 38require Exporter; 39@ISA = qw(Exporter); 40 41# Make sure Testing can do everything its supposed to. 42foreach 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()' ); 56eval { Testing->require_version(1.11); 1 }; 57::ok( $@, 'require_version() fail' ); 58::ok( Testing->require_version(0), 'require_version(0)' ); 59 60sub lifejacket { 'lifejacket' } 61sub stuff { 'stuff' } 62sub Above { 'Above' } 63sub the { 'the' } 64sub Fasten { 'Fasten' } 65sub your { 'your' } 66sub under { 'under' } 67use vars qw($seatbelt $seat @wailing %left); 68$seatbelt = 'seatbelt'; 69$seat = 'seat'; 70@wailing = qw(AHHHHHH); 71%left = ( left => "right" ); 72 73BEGIN {*is = \&Is}; 74sub Is { 'Is' }; 75 76Exporter::export_ok_tags(); 77 78my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; 79my %exportok = map { $_ => 1 } @EXPORT_OK; 80my $ok = 1; 81foreach my $tag (keys %tags) { 82 $ok = exists $exportok{$tag}; 83} 84::ok( $ok, 'export_ok_tags()' ); 85 86 87package Foo; 88Testing->import; 89 90::ok( defined &lifejacket, 'simple import' ); 91 92my $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 111package Bar; 112my @imports = qw($seatbelt &Above stuff @wailing %left); 113Testing->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 121package Yar; 122my @tags = qw(:This :tray); 123Testing->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 132package Err; 133my @missing = qw(first second); 134eval { Testing->import(@missing) }; 135 136for my $func (@missing) { 137 ::ok( $@ =~ /^"$func" is not exported by the Testing module$/m, 138 "$func is not exported error message" ); 139} 140 141 142package Arrr; 143Testing->import(qw(!lifejacket)); 144 145::ok( !defined &lifejacket, 'deny import by !' ); 146 147 148package Mars; 149Testing->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 'import by regex'); 156 157 158package Venus; 159Testing->import('!/e/'); 160 161::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n == \\${s}Testing::$n" } 162 map { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] } 163 grep { /e/ } 164 @Testing::EXPORT, @Testing::EXPORT_OK), 165 'deny import by regex'); 166 167::ok( !defined &lifejacket, 'further denial' ); 168 169 170package More::Testing; 171@ISA = qw(Exporter); 172$VERSION = 0; 173eval { More::Testing->require_version(0); 1 }; 174::ok(!$@, 'require_version(0) and $VERSION = 0'); 175 176 177package Yet::More::Testing; 178@ISA = qw(Exporter); 179$VERSION = 0; 180eval { Yet::More::Testing->require_version(10); 1 }; 181::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); 182 183 184my $warnings; 185BEGIN { 186 local $SIG{__WARN__} = sub { $warnings = join '', @_ }; 187 package Testing::Unused::Vars; 188 @ISA = qw(Exporter); 189 @EXPORT = qw(this $TODO that); 190 191 package Foo; 192 Testing::Unused::Vars->import; 193} 194 195::ok( !$warnings, 'Unused variables can be exported without warning' ) || 196 print "# $warnings\n"; 197 198package Moving::Target; 199@ISA = qw(Exporter); 200@EXPORT_OK = qw (foo); 201 202sub foo {"This is foo"}; 203sub bar {"This is bar"}; 204 205package Moving::Target::Test; 206 207Moving::Target->import ('foo'); 208 209::ok (foo() eq "This is foo", "imported foo before EXPORT_OK changed"); 210 211push @Moving::Target::EXPORT_OK, 'bar'; 212 213Moving::Target->import ('bar'); 214 215::ok (bar() eq "This is bar", "imported bar after EXPORT_OK changed"); 216 217package The::Import; 218 219use Exporter 'import'; 220 221::ok(\&import == \&Exporter::import, "imported the import routine"); 222 223@EXPORT = qw( wibble ); 224sub wibble {return "wobble"}; 225 226package Use::The::Import; 227 228The::Import->import; 229 230my $val = eval { wibble() }; 231::ok($val eq "wobble", "exported importer worked"); 232 233# Check that Carp recognizes Exporter as internal to Perl 234require Carp; 235eval { Carp::croak() }; 236::ok($Carp::Internal{Exporter}, "Carp recognizes Exporter"); 237::ok($Carp::Internal{'Exporter::Heavy'}, "Carp recognizes Exporter::Heavy"); 238 239package Exporter::for::Tied::_; 240 241@ISA = 'Exporter'; 242@EXPORT = 'foo'; 243 244package Tied::_; 245 246sub TIESCALAR{bless[]} 247# no tie methods! 248 249{ 250 tie my $t, __PACKAGE__; 251 for($t) { # $_ is now tied 252 import Exporter::for::Tied::_; 253 } 254} 255::ok(1, 'import with tied $_'); 256