1#!perl -w 2 3use strict; 4use warnings; 5 6# Can't use Test::Simple/More, they depend on Exporter. 7my $test; 8sub ok ($;$) { 9 my($ok, $name) = @_; 10 11 # You have to do it this way or VMS will get confused. 12 printf "%sok %d%s\n", ($ok ? '' : 'not '), $test, 13 (defined $name ? " - $name" : ''); 14 15 printf "# Failed test at line %d\n", (caller)[2] unless $ok; 16 17 $test++; 18 return $ok; 19} 20 21 22BEGIN { 23 $test = 1; 24 print "1..34\n"; 25 require Exporter; 26 ok( 1, 'Exporter compiled' ); 27} 28 29 30our @Exporter_Methods = qw(import 31 export_to_level 32 require_version 33 export_fail 34 ); 35 36 37package Testing; 38require Exporter; 39our @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 46our %EXPORT_TAGS = ( 47 This => [qw(stuff %left)], 48 That => [qw(Above the @wailing)], 49 tray => [qw(Fasten $seatbelt)], 50 ); 51our @EXPORT = qw(lifejacket is); 52our @EXPORT_OK = qw(under &your $seat); 53our $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; 171our @ISA = qw(Exporter); 172our $VERSION = 0; 173eval { More::Testing->require_version(0); 1 }; 174::ok(!$@, 'require_version(0) and $VERSION = 0'); 175 176 177package Yet::More::Testing; 178our @ISA = qw(Exporter); 179our $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 our @ISA = qw(Exporter); 189 our @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; 199our @ISA = qw(Exporter); 200our @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; 218use Exporter 'import'; 219 220::ok(\&import == \&Exporter::import, "imported the import routine"); 221 222our @EXPORT = qw( wibble ); 223sub wibble {return "wobble"}; 224 225package Use::The::Import; 226 227The::Import->import; 228 229my $val = eval { wibble() }; 230::ok($val eq "wobble", "exported importer worked"); 231 232# Check that Carp recognizes Exporter as internal to Perl 233require Carp; 234eval { Carp::croak() }; 235::ok($Carp::Internal{Exporter}, "Carp recognizes Exporter"); 236::ok($Carp::Internal{'Exporter::Heavy'}, "Carp recognizes Exporter::Heavy"); 237 238package Exporter::for::Tied::_; 239 240our @ISA = 'Exporter'; 241our @EXPORT = 'foo'; 242 243package Tied::_; 244 245sub TIESCALAR{bless[]} 246# no tie methods! 247 248{ 249 tie my $t, __PACKAGE__; 250 for($t) { # $_ is now tied 251 import Exporter::for::Tied::_; 252 } 253} 254::ok(1, 'import with tied $_'); 255 256# this should be loaded, but make sure 257require Exporter::Heavy; 258::ok(Exporter->VERSION eq Exporter::Heavy->VERSION, 259 'Exporter and Exporter::Heavy have matching versions'); 260