Commit | Line | Data |
94dd7035 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | # Utility testing functions. |
9 | my $test_num = 1; |
10 | sub ok ($;$) { |
11 | my($test, $name) = @_; |
12 | print "not " unless $test; |
13 | print "ok $test_num"; |
992a8485 |
14 | print " - $name" if (defined $name && ! $^O eq 'VMS'); |
94dd7035 |
15 | print "\n"; |
16 | $test_num++; |
17 | } |
18 | |
19 | |
20 | my $loaded; |
21 | BEGIN { $| = 1; $^W = 1; } |
22 | END {print "not ok $test_num\n" unless $loaded;} |
23 | print "1..$Total_tests\n"; |
24 | use Exporter; |
25 | $loaded = 1; |
26 | ok(1, 'compile'); |
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 | |
38 | BEGIN { $Total_tests = 14 + @Exporter_Methods } |
39 | |
40 | package Testing; |
41 | require Exporter; |
42 | @ISA = qw(Exporter); |
43 | |
44 | # Make sure Testing can do everything its supposed to. |
45 | foreach my $meth (@::Exporter_Methods) { |
46 | ::ok( Testing->can($meth), "subclass can $meth()" ); |
47 | } |
48 | |
49 | %EXPORT_TAGS = ( |
50 | This => [qw(stuff %left)], |
51 | That => [qw(Above the @wailing)], |
52 | tray => [qw(Fasten $seatbelt)], |
53 | ); |
54 | @EXPORT = qw(lifejacket); |
55 | @EXPORT_OK = qw(under &your $seat); |
56 | $VERSION = '1.05'; |
57 | |
58 | ::ok( Testing->require_version(1.05), 'require_version()' ); |
59 | eval { Testing->require_version(1.11); 1 }; |
60 | ::ok( $@, 'require_version() fail' ); |
61 | ::ok( Testing->require_version(0), 'require_version(0)' ); |
62 | |
63 | sub lifejacket { 'lifejacket' } |
64 | sub stuff { 'stuff' } |
65 | sub Above { 'Above' } |
66 | sub the { 'the' } |
67 | sub Fasten { 'Fasten' } |
68 | sub your { 'your' } |
69 | sub under { 'under' } |
70 | use vars qw($seatbelt $seat @wailing %left); |
71 | $seatbelt = 'seatbelt'; |
72 | $seat = 'seat'; |
73 | @wailing = qw(AHHHHHH); |
74 | %left = ( left => "right" ); |
75 | |
76 | |
77 | Exporter::export_ok_tags; |
78 | |
79 | my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; |
80 | my %exportok = map { $_ => 1 } @EXPORT_OK; |
81 | my $ok = 1; |
82 | foreach my $tag (keys %tags) { |
83 | $ok = exists $exportok{$tag}; |
84 | } |
85 | ::ok( $ok, 'export_ok_tags()' ); |
86 | |
87 | |
88 | package Foo; |
89 | Testing->import; |
90 | |
91 | ::ok( defined &lifejacket, 'simple import' ); |
92 | |
93 | |
94 | package Bar; |
95 | my @imports = qw($seatbelt &Above stuff @wailing %left); |
96 | Testing->import(@imports); |
97 | |
98 | ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)), |
99 | 'import by symbols' ); |
100 | |
101 | |
102 | package Yar; |
103 | my @tags = qw(:This :tray); |
104 | Testing->import(@tags); |
105 | |
106 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } |
107 | map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}), |
108 | 'import by tags' ); |
109 | |
110 | |
111 | package Arrr; |
112 | Testing->import(qw(!lifejacket)); |
113 | |
114 | ::ok( !defined &lifejacket, 'deny import by !' ); |
115 | |
116 | |
117 | package Mars; |
118 | Testing->import('/e/'); |
119 | |
120 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } |
121 | grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), |
122 | 'import by regex'); |
123 | |
124 | |
125 | package Venus; |
126 | Testing->import('!/e/'); |
127 | |
128 | ::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ } |
129 | grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), |
130 | 'deny import by regex'); |
131 | ::ok( !defined &lifejacket, 'further denial' ); |
132 | |
133 | |
134 | package More::Testing; |
135 | @ISA = qw(Exporter); |
136 | $VERSION = 0; |
137 | eval { More::Testing->require_version(0); 1 }; |
138 | ::ok(!$@, 'require_version(0) and $VERSION = 0'); |
139 | |
140 | |
141 | package Yet::More::Testing; |
142 | @ISA = qw(Exporter); |
143 | $VERSION = 0; |
144 | eval { Yet::More::Testing->require_version(10); 1 }; |
145 | ::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); |