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 | ||
9ebf09bc JH |
24 | print "1..19\n"; |
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 | ); | |
53 | @EXPORT = qw(lifejacket); | |
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 | ||
75 | ||
76 | Exporter::export_ok_tags; | |
77 | ||
78 | my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; | |
79 | my %exportok = map { $_ => 1 } @EXPORT_OK; | |
80 | my $ok = 1; | |
81 | foreach my $tag (keys %tags) { | |
82 | $ok = exists $exportok{$tag}; | |
83 | } | |
84 | ::ok( $ok, 'export_ok_tags()' ); | |
85 | ||
86 | ||
87 | package Foo; | |
88 | Testing->import; | |
89 | ||
90 | ::ok( defined &lifejacket, 'simple import' ); | |
91 | ||
92 | ||
93 | package Bar; | |
94 | my @imports = qw($seatbelt &Above stuff @wailing %left); | |
95 | Testing->import(@imports); | |
96 | ||
97 | ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)), | |
98 | 'import by symbols' ); | |
99 | ||
100 | ||
101 | package Yar; | |
102 | my @tags = qw(:This :tray); | |
103 | Testing->import(@tags); | |
104 | ||
105 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } | |
106 | map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}), | |
107 | 'import by tags' ); | |
108 | ||
109 | ||
110 | package Arrr; | |
111 | Testing->import(qw(!lifejacket)); | |
112 | ||
113 | ::ok( !defined &lifejacket, 'deny import by !' ); | |
114 | ||
115 | ||
116 | package Mars; | |
117 | Testing->import('/e/'); | |
118 | ||
119 | ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } | |
120 | grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), | |
121 | 'import by regex'); | |
122 | ||
123 | ||
124 | package Venus; | |
125 | Testing->import('!/e/'); | |
126 | ||
127 | ::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ } | |
128 | grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), | |
129 | 'deny import by regex'); | |
130 | ::ok( !defined &lifejacket, 'further denial' ); | |
131 | ||
132 | ||
133 | package More::Testing; | |
134 | @ISA = qw(Exporter); | |
135 | $VERSION = 0; | |
136 | eval { More::Testing->require_version(0); 1 }; | |
137 | ::ok(!$@, 'require_version(0) and $VERSION = 0'); | |
138 | ||
139 | ||
140 | package Yet::More::Testing; | |
141 | @ISA = qw(Exporter); | |
142 | $VERSION = 0; | |
143 | eval { Yet::More::Testing->require_version(10); 1 }; | |
144 | ::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); | |
9ebf09bc JH |
145 | |
146 | ||
147 | my $warnings; | |
148 | BEGIN { | |
149 | $SIG{__WARN__} = sub { $warnings = join '', @_ }; | |
150 | package Testing::Unused::Vars; | |
151 | @ISA = qw(Exporter); | |
152 | @EXPORT = qw(this $TODO that); | |
153 | ||
154 | package Foo; | |
155 | Testing::Unused::Vars->import; | |
156 | } | |
157 | ||
158 | ::ok( !$warnings, 'Unused variables can be exported without warning' ) || | |
159 | print "# $warnings\n"; | |
160 |