Commit | Line | Data |
---|---|---|
94dd7035 MS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
9ebf09bc JH |
8 | # Can't use Test::Simple/More, they depend on Exporter. |
9 | my $test = 1; | |
94dd7035 | 10 | sub ok ($;$) { |
9ebf09bc JH |
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; | |
94dd7035 MS |
21 | } |
22 | ||
23 | ||
d7341064 | 24 | print "1..24\n"; |
9ebf09bc JH |
25 | require Exporter; |
26 | ok( 1, 'Exporter compiled' ); | |
94dd7035 MS |
27 | |
28 | ||
29 | BEGIN { | |
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 | ||
94dd7035 MS |
38 | |
39 | package Testing; | |
40 | require Exporter; | |
41 | @ISA = qw(Exporter); | |
42 | ||
43 | # Make sure Testing can do everything its supposed to. | |
44 | foreach 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 | ); | |
d7341064 | 53 | @EXPORT = qw(lifejacket is); |
94dd7035 MS |
54 | @EXPORT_OK = qw(under &your $seat); |
55 | $VERSION = '1.05'; | |
56 | ||
57 | ::ok( Testing->require_version(1.05), 'require_version()' ); | |
58 | eval { Testing->require_version(1.11); 1 }; | |
59 | ::ok( $@, 'require_version() fail' ); | |
60 | ::ok( Testing->require_version(0), 'require_version(0)' ); | |
61 | ||
62 | sub lifejacket { 'lifejacket' } | |
63 | sub stuff { 'stuff' } | |
64 | sub Above { 'Above' } | |
65 | sub the { 'the' } | |
66 | sub Fasten { 'Fasten' } | |
67 | sub your { 'your' } | |
68 | sub under { 'under' } | |
69 | use vars qw($seatbelt $seat @wailing %left); | |
70 | $seatbelt = 'seatbelt'; | |
71 | $seat = 'seat'; | |
72 | @wailing = qw(AHHHHHH); | |
73 | %left = ( left => "right" ); | |
74 | ||
d7341064 NC |
75 | BEGIN {*is = \&Is}; |
76 | sub Is { 'Is' }; | |
94dd7035 MS |
77 | |
78 | Exporter::export_ok_tags; | |
79 | ||
80 | my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; | |
81 | my %exportok = map { $_ => 1 } @EXPORT_OK; | |
82 | my $ok = 1; | |
83 | foreach my $tag (keys %tags) { | |
84 | $ok = exists $exportok{$tag}; | |
85 | } | |
86 | ::ok( $ok, 'export_ok_tags()' ); | |
87 | ||
88 | ||
89 | package Foo; | |
90 | Testing->import; | |
91 | ||
92 | ::ok( defined &lifejacket, 'simple import' ); | |
93 | ||
d7341064 NC |
94 | my $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" ); | |
105 | my $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 | ||
94dd7035 MS |
112 | |
113 | package Bar; | |
114 | my @imports = qw($seatbelt &Above stuff @wailing %left); | |
115 | Testing->import(@imports); | |
116 | ||
117 | ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)), | |
118 | 'import by symbols' ); | |
119 | ||
120 | ||
121 | package Yar; | |
122 | my @tags = qw(:This :tray); | |
123 | Testing->import(@tags); | |
124 | ||
125 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } | |
126 | map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}), | |
127 | 'import by tags' ); | |
128 | ||
129 | ||
130 | package Arrr; | |
131 | Testing->import(qw(!lifejacket)); | |
132 | ||
133 | ::ok( !defined &lifejacket, 'deny import by !' ); | |
134 | ||
135 | ||
136 | package Mars; | |
137 | Testing->import('/e/'); | |
138 | ||
139 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } | |
140 | grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), | |
141 | 'import by regex'); | |
142 | ||
143 | ||
144 | package Venus; | |
145 | Testing->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 | ||
153 | package More::Testing; | |
154 | @ISA = qw(Exporter); | |
155 | $VERSION = 0; | |
156 | eval { More::Testing->require_version(0); 1 }; | |
157 | ::ok(!$@, 'require_version(0) and $VERSION = 0'); | |
158 | ||
159 | ||
160 | package Yet::More::Testing; | |
161 | @ISA = qw(Exporter); | |
162 | $VERSION = 0; | |
163 | eval { Yet::More::Testing->require_version(10); 1 }; | |
164 | ::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); | |
9ebf09bc JH |
165 | |
166 | ||
167 | my $warnings; | |
168 | BEGIN { | |
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 |