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