Profile of Test/More.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:22 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/Test/More.pm
Statements | Executed 40 statements in 2.99ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 261µs | 50.1ms | Test::More::::BEGIN@22Test::More::BEGIN@22
1 | 1 | 1 | 14µs | 14µs | Test::More::::BEGIN@3Test::More::BEGIN@3
1 | 1 | 1 | 13µs | 275µs | Test::More::::okTest::More::ok
1 | 1 | 1 | 11µs | 13µs | Test::More::::import_extraTest::More::import_extra
1 | 1 | 1 | 7µs | 11µs | Test::More::::BEGIN@209Test::More::BEGIN@209
1 | 1 | 1 | 7µs | 363µs | Test::More::::done_testingTest::More::done_testing
1 | 1 | 1 | 6µs | 29µs | Test::More::::BEGIN@1408Test::More::BEGIN@1408
1 | 1 | 1 | 5µs | 34µs | Test::More::::BEGIN@1783Test::More::BEGIN@1783
1 | 1 | 1 | 4µs | 16µs | Test::More::::BEGIN@1494Test::More::BEGIN@1494
1 | 1 | 1 | 4µs | 6µs | Test::More::::BEGIN@4Test::More::BEGIN@4
1 | 1 | 1 | 3µs | 19µs | Test::More::::BEGIN@5Test::More::BEGIN@5
0 | 0 | 0 | 0s | 0s | Test::More::::BAIL_OUTTest::More::BAIL_OUT
0 | 0 | 0 | 0s | 0s | Test::More::::__ANON__[:584]Test::More::__ANON__[:584]
0 | 0 | 0 | 0s | 0s | Test::More::::__ANON__[:653]Test::More::__ANON__[:653]
0 | 0 | 0 | 0s | 0s | Test::More::::__ANON__[:741]Test::More::__ANON__[:741]
0 | 0 | 0 | 0s | 0s | Test::More::::_carpTest::More::_carp
0 | 0 | 0 | 0s | 0s | Test::More::::_deep_checkTest::More::_deep_check
0 | 0 | 0 | 0s | 0s | Test::More::::_dneTest::More::_dne
0 | 0 | 0 | 0s | 0s | Test::More::::_eq_arrayTest::More::_eq_array
0 | 0 | 0 | 0s | 0s | Test::More::::_eq_hashTest::More::_eq_hash
0 | 0 | 0 | 0s | 0s | Test::More::::_equal_nonrefsTest::More::_equal_nonrefs
0 | 0 | 0 | 0s | 0s | Test::More::::_evalTest::More::_eval
0 | 0 | 0 | 0s | 0s | Test::More::::_format_stackTest::More::_format_stack
0 | 0 | 0 | 0s | 0s | Test::More::::_is_module_nameTest::More::_is_module_name
0 | 0 | 0 | 0s | 0s | Test::More::::_typeTest::More::_type
0 | 0 | 0 | 0s | 0s | Test::More::::_whoaTest::More::_whoa
0 | 0 | 0 | 0s | 0s | Test::More::::can_okTest::More::can_ok
0 | 0 | 0 | 0s | 0s | Test::More::::cmp_okTest::More::cmp_ok
0 | 0 | 0 | 0s | 0s | Test::More::::diagTest::More::diag
0 | 0 | 0 | 0s | 0s | Test::More::::eq_arrayTest::More::eq_array
0 | 0 | 0 | 0s | 0s | Test::More::::eq_hashTest::More::eq_hash
0 | 0 | 0 | 0s | 0s | Test::More::::eq_setTest::More::eq_set
0 | 0 | 0 | 0s | 0s | Test::More::::explainTest::More::explain
0 | 0 | 0 | 0s | 0s | Test::More::::failTest::More::fail
0 | 0 | 0 | 0s | 0s | Test::More::::isTest::More::is
0 | 0 | 0 | 0s | 0s | Test::More::::is_deeplyTest::More::is_deeply
0 | 0 | 0 | 0s | 0s | Test::More::::isa_okTest::More::isa_ok
0 | 0 | 0 | 0s | 0s | Test::More::::isntTest::More::isnt
0 | 0 | 0 | 0s | 0s | Test::More::::likeTest::More::like
0 | 0 | 0 | 0s | 0s | Test::More::::new_okTest::More::new_ok
0 | 0 | 0 | 0s | 0s | Test::More::::noteTest::More::note
0 | 0 | 0 | 0s | 0s | Test::More::::passTest::More::pass
0 | 0 | 0 | 0s | 0s | Test::More::::planTest::More::plan
0 | 0 | 0 | 0s | 0s | Test::More::::require_okTest::More::require_ok
0 | 0 | 0 | 0s | 0s | Test::More::::skipTest::More::skip
0 | 0 | 0 | 0s | 0s | Test::More::::subtestTest::More::subtest
0 | 0 | 0 | 0s | 0s | Test::More::::todo_skipTest::More::todo_skip
0 | 0 | 0 | 0s | 0s | Test::More::::unlikeTest::More::unlike
0 | 0 | 0 | 0s | 0s | Test::More::::use_okTest::More::use_ok
0 | 0 | 0 | 0s | 0s | isn::::t isn::t

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Test::More;
2 |  |  |  |  |
3 | 2 | 32µs | 1 | 14µs | # spent 14µs within Test::More::BEGIN@3 which was called: # once (14µs+0s) by main::BEGIN@5 at line 3 use 5.006; # spent 14µs making 1 call to Test::More::BEGIN@3
4 | 2 | 15µs | 2 | 8µs | # spent 6µs (4+2) within Test::More::BEGIN@4 which was called: # once (4µs+2µs) by main::BEGIN@5 at line 4 use strict; # spent 6µs making 1 call to Test::More::BEGIN@4 # spent 2µs making 1 call to strict::import
5 | 2 | 70µs | 2 | 34µs | # spent 19µs (3+16) within Test::More::BEGIN@5 which was called: # once (3µs+16µs) by main::BEGIN@5 at line 5 use warnings; # spent 19µs making 1 call to Test::More::BEGIN@5 # spent 16µs making 1 call to warnings::import
6 |  |  |  |  |
7 |  |  |  |  | #---- perlcritic exemptions. ----#
8 |  |  |  |  |
9 |  |  |  |  | # We use a lot of subroutine prototypes
10 |  |  |  |  | ## no critic (Subroutines::ProhibitSubroutinePrototypes)
11 |  |  |  |  |
12 |  |  |  |  | # Can't use Carp because it might cause C<use_ok()> to accidentally succeed
13 |  |  |  |  | # even though the module being used forgot to use Carp. Yes, this
14 |  |  |  |  | # actually happened.
15 |  |  |  |  | sub _carp {
16 |  |  |  |  | my( $file, $line ) = ( caller(1) )[ 1, 2 ];
17 |  |  |  |  | return warn @_, " at $file line $line\n";
18 |  |  |  |  | }
19 |  |  |  |  |
20 | 1 | 400ns |  |  | our $VERSION = '1.302198';
21 |  |  |  |  |
22 | 2 | 271µs | 2 | 50.6ms | # spent 50.1ms (261µs+49.8) within Test::More::BEGIN@22 which was called: # once (261µs+49.8ms) by main::BEGIN@5 at line 22 use Test::Builder::Module; # spent 50.1ms making 1 call to Test::More::BEGIN@22 # spent 494µs making 1 call to Test::Builder::Module::import
23 | 1 | 8µs |  |  | our @ISA = qw(Test::Builder::Module);
24 | 1 | 2µs |  |  | our @EXPORT = qw(ok use_ok require_ok
25 |  |  |  |  | is isnt like unlike is_deeply
26 |  |  |  |  | cmp_ok
27 |  |  |  |  | skip todo todo_skip
28 |  |  |  |  | pass fail
29 |  |  |  |  | eq_array eq_hash eq_set
30 |  |  |  |  | $TODO
31 |  |  |  |  | plan
32 |  |  |  |  | done_testing
33 |  |  |  |  | can_ok isa_ok new_ok
34 |  |  |  |  | diag note explain
35 |  |  |  |  | subtest
36 |  |  |  |  | BAIL_OUT
37 |  |  |  |  | );
38 |  |  |  |  |
39 |  |  |  |  | =head1 NAME
40 |  |  |  |  |
41 |  |  |  |  | Test::More - yet another framework for writing test scripts
42 |  |  |  |  |
43 |  |  |  |  | =head1 SYNOPSIS
44 |  |  |  |  |
45 |  |  |  |  | use Test::More tests => 23;
46 |  |  |  |  | # or
47 |  |  |  |  | use Test::More skip_all => $reason;
48 |  |  |  |  | # or
49 |  |  |  |  | use Test::More; # see done_testing()
50 |  |  |  |  |
51 |  |  |  |  | require_ok( 'Some::Module' );
52 |  |  |  |  |
53 |  |  |  |  | # Various ways to say "ok"
54 |  |  |  |  | ok($got eq $expected, $test_name);
55 |  |  |  |  |
56 |  |  |  |  | is ($got, $expected, $test_name);
57 |  |  |  |  | isnt($got, $expected, $test_name);
58 |  |  |  |  |
59 |  |  |  |  | # Rather than print STDERR "# here's what went wrong\n"
60 |  |  |  |  | diag("here's what went wrong");
61 |  |  |  |  |
62 |  |  |  |  | like ($got, qr/expected/, $test_name);
63 |  |  |  |  | unlike($got, qr/expected/, $test_name);
64 |  |  |  |  |
65 |  |  |  |  | cmp_ok($got, '==', $expected, $test_name);
66 |  |  |  |  |
67 |  |  |  |  | is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
68 |  |  |  |  |
69 |  |  |  |  | SKIP: {
70 |  |  |  |  | skip $why, $how_many unless $have_some_feature;
71 |  |  |  |  |
72 |  |  |  |  | ok( foo(), $test_name );
73 |  |  |  |  | is( foo(42), 23, $test_name );
74 |  |  |  |  | };
75 |  |  |  |  |
76 |  |  |  |  | TODO: {
77 |  |  |  |  | local $TODO = $why;
78 |  |  |  |  |
79 |  |  |  |  | ok( foo(), $test_name );
80 |  |  |  |  | is( foo(42), 23, $test_name );
81 |  |  |  |  | };
82 |  |  |  |  |
83 |  |  |  |  | can_ok($module, @methods);
84 |  |  |  |  | isa_ok($object, $class);
85 |  |  |  |  |
86 |  |  |  |  | pass($test_name);
87 |  |  |  |  | fail($test_name);
88 |  |  |  |  |
89 |  |  |  |  | BAIL_OUT($why);
90 |  |  |  |  |
91 |  |  |  |  | # UNIMPLEMENTED!!!
92 |  |  |  |  | my @status = Test::More::status;
93 |  |  |  |  |
94 |  |  |  |  |
95 |  |  |  |  | =head1 DESCRIPTION
96 |  |  |  |  |
97 |  |  |  |  | B<STOP!> If you're just getting started writing tests, have a look at
98 |  |  |  |  | L<Test2::Suite> first.
99 |  |  |  |  |
100 |  |  |  |  | This is a drop in replacement for Test::Simple which you can switch to once you
101 |  |  |  |  | get the hang of basic testing.
102 |  |  |  |  |
103 |  |  |  |  | The purpose of this module is to provide a wide range of testing
104 |  |  |  |  | utilities. Various ways to say "ok" with better diagnostics,
105 |  |  |  |  | facilities to skip tests, test future features and compare complicated
106 |  |  |  |  | data structures. While you can do almost anything with a simple
107 |  |  |  |  | C<ok()> function, it doesn't provide good diagnostic output.
108 |  |  |  |  |
109 |  |  |  |  |
110 |  |  |  |  | =head2 I love it when a plan comes together
111 |  |  |  |  |
112 |  |  |  |  | Before anything else, you need a testing plan. This basically declares
113 |  |  |  |  | how many tests your script is going to run to protect against premature
114 |  |  |  |  | failure.
115 |  |  |  |  |
116 |  |  |  |  | The preferred way to do this is to declare a plan when you C<use Test::More>.
117 |  |  |  |  |
118 |  |  |  |  | use Test::More tests => 23;
119 |  |  |  |  |
120 |  |  |  |  | There are cases when you will not know beforehand how many tests your
121 |  |  |  |  | script is going to run. In this case, you can declare your tests at
122 |  |  |  |  | the end.
123 |  |  |  |  |
124 |  |  |  |  | use Test::More;
125 |  |  |  |  |
126 |  |  |  |  | ... run your tests ...
127 |  |  |  |  |
128 |  |  |  |  | done_testing( $number_of_tests_run );
129 |  |  |  |  |
130 |  |  |  |  | B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block.
131 |  |  |  |  |
132 |  |  |  |  | Sometimes you really don't know how many tests were run, or it's too
133 |  |  |  |  | difficult to calculate. In which case you can leave off
134 |  |  |  |  | $number_of_tests_run.
135 |  |  |  |  |
136 |  |  |  |  | In some cases, you'll want to completely skip an entire testing script.
137 |  |  |  |  |
138 |  |  |  |  | use Test::More skip_all => $skip_reason;
139 |  |  |  |  |
140 |  |  |  |  | Your script will declare a skip with the reason why you skipped and
141 |  |  |  |  | exit immediately with a zero (success). See L<Test::Harness> for
142 |  |  |  |  | details.
143 |  |  |  |  |
144 |  |  |  |  | If you want to control what functions Test::More will export, you
145 |  |  |  |  | have to use the 'import' option. For example, to import everything
146 |  |  |  |  | but 'fail', you'd do:
147 |  |  |  |  |
148 |  |  |  |  | use Test::More tests => 23, import => ['!fail'];
149 |  |  |  |  |
150 |  |  |  |  | Alternatively, you can use the C<plan()> function. Useful for when you
151 |  |  |  |  | have to calculate the number of tests.
152 |  |  |  |  |
153 |  |  |  |  | use Test::More;
154 |  |  |  |  | plan tests => keys %Stuff * 3;
155 |  |  |  |  |
156 |  |  |  |  | or for deciding between running the tests at all:
157 |  |  |  |  |
158 |  |  |  |  | use Test::More;
159 |  |  |  |  | if( $^O eq 'MacOS' ) {
160 |  |  |  |  | plan skip_all => 'Test irrelevant on MacOS';
161 |  |  |  |  | }
162 |  |  |  |  | else {
163 |  |  |  |  | plan tests => 42;
164 |  |  |  |  | }
165 |  |  |  |  |
166 |  |  |  |  | =cut
167 |  |  |  |  |
168 |  |  |  |  | sub plan {
169 |  |  |  |  | my $tb = Test::More->builder;
170 |  |  |  |  |
171 |  |  |  |  | return $tb->plan(@_);
172 |  |  |  |  | }
173 |  |  |  |  |
174 |  |  |  |  | # This implements "use Test::More 'no_diag'" but the behavior is
175 |  |  |  |  | # deprecated.
176 |  |  |  |  | # spent 13µs (11+2) within Test::More::import_extra which was called: # once (11µs+2µs) by Test::Builder::Module::import at line 89 of Test/Builder/Module.pm sub import_extra {
177 | 1 | 200ns |  |  | my $class = shift;
178 | 1 | 200ns |  |  | my $list = shift;
179 |  |  |  |  |
180 | 1 | 200ns |  |  | my @other = ();
181 | 1 | 100ns |  |  | my $idx = 0;
182 | 1 | 100ns |  |  | my $import;
183 | 1 | 500ns |  |  | while( $idx <= $#{$list} ) {
184 |  |  |  |  | my $item = $list->[$idx];
185 |  |  |  |  |
186 |  |  |  |  | if( defined $item and $item eq 'no_diag' ) {
187 |  |  |  |  | $class->builder->no_diag(1);
188 |  |  |  |  | }
189 |  |  |  |  | elsif( defined $item and $item eq 'import' ) {
190 |  |  |  |  | if ($import) {
191 |  |  |  |  | push @$import, @{$list->[ ++$idx ]};
192 |  |  |  |  | }
193 |  |  |  |  | else {
194 |  |  |  |  | $import = $list->[ ++$idx ];
195 |  |  |  |  | push @other, $item, $import;
196 |  |  |  |  | }
197 |  |  |  |  | }
198 |  |  |  |  | else {
199 |  |  |  |  | push @other, $item;
200 |  |  |  |  | }
201 |  |  |  |  |
202 |  |  |  |  | $idx++;
203 |  |  |  |  | }
204 |  |  |  |  |
205 | 1 | 300ns |  |  | @$list = @other;
206 |  |  |  |  |
207 | 1 | 500ns |  |  | if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) {
208 | 1 | 1µs | 2 | 2µs | my $to = $class->builder->exported_to; # spent 2µs making 1 call to Test::Builder::Module::builder # spent 800ns making 1 call to Test::Builder::exported_to
209 | 2 | 1.77ms | 2 | 16µs | # spent 11µs (7+4) within Test::More::BEGIN@209 which was called: # once (7µs+4µs) by main::BEGIN@5 at line 209 no strict 'refs'; # spent 11µs making 1 call to Test::More::BEGIN@209 # spent 4µs making 1 call to strict::unimport
210 | 1 | 2µs |  |  | *{"$to\::TODO"} = \our $TODO;
211 | 1 | 600ns |  |  | if ($import) {
212 |  |  |  |  | @$import = grep $_ ne '$TODO', @$import;
213 |  |  |  |  | }
214 |  |  |  |  | else {
215 | 1 | 3µs |  |  | push @$list, import => [grep $_ ne '$TODO', @EXPORT];
216 |  |  |  |  | }
217 |  |  |  |  | }
218 |  |  |  |  |
219 | 1 | 2µs |  |  | return;
220 |  |  |  |  | }
221 |  |  |  |  |
222 |  |  |  |  | =over 4
223 |  |  |  |  |
224 |  |  |  |  | =item B<done_testing>
225 |  |  |  |  |
226 |  |  |  |  | done_testing();
227 |  |  |  |  | done_testing($number_of_tests);
228 |  |  |  |  |
229 |  |  |  |  | If you don't know how many tests you're going to run, you can issue
230 |  |  |  |  | the plan when you're done running tests.
231 |  |  |  |  |
232 |  |  |  |  | $number_of_tests is the same as C<plan()>, it's the number of tests you
233 |  |  |  |  | expected to run. You can omit this, in which case the number of tests
234 |  |  |  |  | you ran doesn't matter, just the fact that your tests ran to
235 |  |  |  |  | conclusion.
236 |  |  |  |  |
237 |  |  |  |  | This is safer than and replaces the "no_plan" plan.
238 |  |  |  |  |
239 |  |  |  |  | B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block.
240 |  |  |  |  | The plan is there to ensure your test does not exit before testing has
241 |  |  |  |  | completed. If you use an END block you completely bypass this protection.
242 |  |  |  |  |
243 |  |  |  |  | =back
244 |  |  |  |  |
245 |  |  |  |  | =cut
246 |  |  |  |  |
247 |  |  |  |  | # spent 363µs (7+356) within Test::More::done_testing which was called: # once (7µs+356µs) by main::RUNTIME at line 16 of /home/micha/Projekt/spreadsheet-parsexlsx/t/bug-md-11.t sub done_testing {
248 | 1 | 1µs | 1 | 2µs | my $tb = Test::More->builder; # spent 2µs making 1 call to Test::Builder::Module::builder
249 | 1 | 4µs | 1 | 353µs | $tb->done_testing(@_); # spent 353µs making 1 call to Test::Builder::done_testing
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | =head2 Test names
253 |  |  |  |  |
254 |  |  |  |  | By convention, each test is assigned a number in order. This is
255 |  |  |  |  | largely done automatically for you. However, it's often very useful to
256 |  |  |  |  | assign a name to each test. Which would you rather see:
257 |  |  |  |  |
258 |  |  |  |  | ok 4
259 |  |  |  |  | not ok 5
260 |  |  |  |  | ok 6
261 |  |  |  |  |
262 |  |  |  |  | or
263 |  |  |  |  |
264 |  |  |  |  | ok 4 - basic multi-variable
265 |  |  |  |  | not ok 5 - simple exponential
266 |  |  |  |  | ok 6 - force == mass * acceleration
267 |  |  |  |  |
268 |  |  |  |  | The later gives you some idea of what failed. It also makes it easier
269 |  |  |  |  | to find the test in your script, simply search for "simple
270 |  |  |  |  | exponential".
271 |  |  |  |  |
272 |  |  |  |  | All test functions take a name argument. It's optional, but highly
273 |  |  |  |  | suggested that you use it.
274 |  |  |  |  |
275 |  |  |  |  | =head2 I'm ok, you're not ok.
276 |  |  |  |  |
277 |  |  |  |  | The basic purpose of this module is to print out either "ok #" or "not
278 |  |  |  |  | ok #" depending on if a given test succeeded or failed. Everything
279 |  |  |  |  | else is just gravy.
280 |  |  |  |  |
281 |  |  |  |  | All of the following print "ok" or "not ok" depending on if the test
282 |  |  |  |  | succeeded or failed. They all also return true or false,
283 |  |  |  |  | respectively.
284 |  |  |  |  |
285 |  |  |  |  | =over 4
286 |  |  |  |  |
287 |  |  |  |  | =item B<ok>
288 |  |  |  |  |
289 |  |  |  |  | ok($got eq $expected, $test_name);
290 |  |  |  |  |
291 |  |  |  |  | This simply evaluates any expression (C<$got eq $expected> is just a
292 |  |  |  |  | simple example) and uses that to determine if the test succeeded or
293 |  |  |  |  | failed. A true expression passes, a false one fails. Very simple.
294 |  |  |  |  |
295 |  |  |  |  | For example:
296 |  |  |  |  |
297 |  |  |  |  | ok( $exp{9} == 81, 'simple exponential' );
298 |  |  |  |  | ok( Film->can('db_Main'), 'set_db()' );
299 |  |  |  |  | ok( $p->tests == 4, 'saw tests' );
300 |  |  |  |  | ok( !grep(!defined $_, @items), 'all items defined' );
301 |  |  |  |  |
302 |  |  |  |  | (Mnemonic: "This is ok.")
303 |  |  |  |  |
304 |  |  |  |  | $test_name is a very short description of the test that will be printed
305 |  |  |  |  | out. It makes it very easy to find a test in your script when it fails
306 |  |  |  |  | and gives others an idea of your intentions. $test_name is optional,
307 |  |  |  |  | but we B<very> strongly encourage its use.
308 |  |  |  |  |
309 |  |  |  |  | Should an C<ok()> fail, it will produce some diagnostics:
310 |  |  |  |  |
311 |  |  |  |  | not ok 18 - sufficient mucus
312 |  |  |  |  | # Failed test 'sufficient mucus'
313 |  |  |  |  | # in foo.t at line 42.
314 |  |  |  |  |
315 |  |  |  |  | This is the same as L<Test::Simple>'s C<ok()> routine.
316 |  |  |  |  |
317 |  |  |  |  | =cut
318 |  |  |  |  |
319 |  |  |  |  | # spent 275µs (13+263) within Test::More::ok which was called: # once (13µs+263µs) by main::RUNTIME at line 14 of /home/micha/Projekt/spreadsheet-parsexlsx/t/bug-md-11.t sub ok ($;$) {
320 | 1 | 700ns |  |  | my( $test, $name ) = @_;
321 | 1 | 7µs | 1 | 7µs | my $tb = Test::More->builder; # spent 7µs making 1 call to Test::Builder::Module::builder
322 |  |  |  |  |
323 | 1 | 4µs | 1 | 256µs | return $tb->ok( $test, $name ); # spent 256µs making 1 call to Test::Builder::ok
324 |  |  |  |  | }
325 |  |  |  |  |
326 |  |  |  |  | =item B<is>
327 |  |  |  |  |
328 |  |  |  |  | =item B<isnt>
329 |  |  |  |  |
330 |  |  |  |  | is ( $got, $expected, $test_name );
331 |  |  |  |  | isnt( $got, $expected, $test_name );
332 |  |  |  |  |
333 |  |  |  |  | Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments
334 |  |  |  |  | with C<eq> and C<ne> respectively and use the result of that to
335 |  |  |  |  | determine if the test succeeded or failed. So these:
336 |  |  |  |  |
337 |  |  |  |  | # Is the ultimate answer 42?
338 |  |  |  |  | is( ultimate_answer(), 42, "Meaning of Life" );
339 |  |  |  |  |
340 |  |  |  |  | # $foo isn't empty
341 |  |  |  |  | isnt( $foo, '', "Got some foo" );
342 |  |  |  |  |
343 |  |  |  |  | are similar to these:
344 |  |  |  |  |
345 |  |  |  |  | ok( ultimate_answer() eq 42, "Meaning of Life" );
346 |  |  |  |  | ok( $foo ne '', "Got some foo" );
347 |  |  |  |  |
348 |  |  |  |  | C<undef> will only ever match C<undef>. So you can test a value
349 |  |  |  |  | against C<undef> like this:
350 |  |  |  |  |
351 |  |  |  |  | is($not_defined, undef, "undefined as expected");
352 |  |  |  |  |
353 |  |  |  |  | (Mnemonic: "This is that." "This isn't that.")
354 |  |  |  |  |
355 |  |  |  |  | So why use these? They produce better diagnostics on failure. C<ok()>
356 |  |  |  |  | cannot know what you are testing for (beyond the name), but C<is()> and
357 |  |  |  |  | C<isnt()> know what the test was and why it failed. For example this
358 |  |  |  |  | test:
359 |  |  |  |  |
360 |  |  |  |  | my $foo = 'waffle'; my $bar = 'yarblokos';
361 |  |  |  |  | is( $foo, $bar, 'Is foo the same as bar?' );
362 |  |  |  |  |
363 |  |  |  |  | Will produce something like this:
364 |  |  |  |  |
365 |  |  |  |  | not ok 17 - Is foo the same as bar?
366 |  |  |  |  | # Failed test 'Is foo the same as bar?'
367 |  |  |  |  | # in foo.t at line 139.
368 |  |  |  |  | # got: 'waffle'
369 |  |  |  |  | # expected: 'yarblokos'
370 |  |  |  |  |
371 |  |  |  |  | So you can figure out what went wrong without rerunning the test.
372 |  |  |  |  |
373 |  |  |  |  | You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible,
374 |  |  |  |  | however do not be tempted to use them to find out if something is
375 |  |  |  |  | true or false!
376 |  |  |  |  |
377 |  |  |  |  | # XXX BAD!
378 |  |  |  |  | is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
379 |  |  |  |  |
380 |  |  |  |  | This does not check if C<exists $brooklyn{tree}> is true, it checks if
381 |  |  |  |  | it returns 1. Very different. Similar caveats exist for false and 0.
382 |  |  |  |  | In these cases, use C<ok()>.
383 |  |  |  |  |
384 |  |  |  |  | ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
385 |  |  |  |  |
386 |  |  |  |  | A simple call to C<isnt()> usually does not provide a strong test but there
387 |  |  |  |  | are cases when you cannot say much more about a value than that it is
388 |  |  |  |  | different from some other value:
389 |  |  |  |  |
390 |  |  |  |  | new_ok $obj, "Foo";
391 |  |  |  |  |
392 |  |  |  |  | my $clone = $obj->clone;
393 |  |  |  |  | isa_ok $obj, "Foo", "Foo->clone";
394 |  |  |  |  |
395 |  |  |  |  | isnt $obj, $clone, "clone() produces a different object";
396 |  |  |  |  |
397 |  |  |  |  | Historically we supported an C<isn't()> function as an alias of
398 |  |  |  |  | C<isnt()>, however in Perl 5.37.9 support for the use of aprostrophe as
399 |  |  |  |  | a package separator was deprecated and by Perl 5.42.0 support for it
400 |  |  |  |  | will have been removed completely. Accordingly use of C<isn't()> is also
401 |  |  |  |  | deprecated, and will produce warnings when used unless 'deprecated'
402 |  |  |  |  | warnings are specifically disabled in the scope where it is used. You
403 |  |  |  |  | are strongly advised to migrate to using C<isnt()> instead.
404 |  |  |  |  |
405 |  |  |  |  | =cut
406 |  |  |  |  |
407 |  |  |  |  | sub is ($$;$) {
408 |  |  |  |  | my $tb = Test::More->builder;
409 |  |  |  |  |
410 |  |  |  |  | return $tb->is_eq(@_);
411 |  |  |  |  | }
412 |  |  |  |  |
413 |  |  |  |  | sub isnt ($$;$) {
414 |  |  |  |  | my $tb = Test::More->builder;
415 |  |  |  |  |
416 |  |  |  |  | return $tb->isnt_eq(@_);
417 |  |  |  |  | }
418 |  |  |  |  |
419 |  |  |  |  | # Historically it was possible to use apostrophes as a package
420 |  |  |  |  | # separator. make this available as isn't() for perl's that support it.
421 |  |  |  |  | # However in 5.37.9 the apostrophe as a package separator was
422 |  |  |  |  | # deprecated, so warn users of isn't() that they should use isnt()
423 |  |  |  |  | # instead. We assume that if they are calling isn::t() they are doing so
424 |  |  |  |  | # via isn't() as we have no way to be sure that they aren't spelling it
425 |  |  |  |  | # with a double colon. We only trigger the warning if deprecation
426 |  |  |  |  | # warnings are enabled, so the user can silence the warning if they
427 |  |  |  |  | # wish.
428 |  |  |  |  | sub isn::t {
429 |  |  |  |  | local ($@, $!, $?);
430 |  |  |  |  | if (warnings::enabled("deprecated")) {
431 |  |  |  |  | _carp
432 |  |  |  |  | "Use of apostrophe as package separator was deprecated in Perl 5.37.9,\n",
433 |  |  |  |  | "and will be removed in Perl 5.42.0. You should change code that uses\n",
434 |  |  |  |  | "Test::More::isn't() to use Test::More::isnt() as a replacement";
435 |  |  |  |  | }
436 |  |  |  |  | goto &isnt;
437 |  |  |  |  | }
438 |  |  |  |  |
439 |  |  |  |  | =item B<like>
440 |  |  |  |  |
441 |  |  |  |  | like( $got, qr/expected/, $test_name );
442 |  |  |  |  |
443 |  |  |  |  | Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>.
444 |  |  |  |  |
445 |  |  |  |  | So this:
446 |  |  |  |  |
447 |  |  |  |  | like($got, qr/expected/, 'this is like that');
448 |  |  |  |  |
449 |  |  |  |  | is similar to:
450 |  |  |  |  |
451 |  |  |  |  | ok( $got =~ m/expected/, 'this is like that');
452 |  |  |  |  |
453 |  |  |  |  | (Mnemonic "This is like that".)
454 |  |  |  |  |
455 |  |  |  |  | The second argument is a regular expression. It may be given as a
456 |  |  |  |  | regex reference (i.e. C<qr//>) or (for better compatibility with older
457 |  |  |  |  | perls) as a string that looks like a regex (alternative delimiters are
458 |  |  |  |  | currently not supported):
459 |  |  |  |  |
460 |  |  |  |  | like( $got, '/expected/', 'this is like that' );
461 |  |  |  |  |
462 |  |  |  |  | Regex options may be placed on the end (C<'/expected/i'>).
463 |  |  |  |  |
464 |  |  |  |  | Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better
465 |  |  |  |  | diagnostics on failure.
466 |  |  |  |  |
467 |  |  |  |  | =cut
468 |  |  |  |  |
469 |  |  |  |  | sub like ($$;$) {
470 |  |  |  |  | my $tb = Test::More->builder;
471 |  |  |  |  |
472 |  |  |  |  | return $tb->like(@_);
473 |  |  |  |  | }
474 |  |  |  |  |
475 |  |  |  |  | =item B<unlike>
476 |  |  |  |  |
477 |  |  |  |  | unlike( $got, qr/expected/, $test_name );
478 |  |  |  |  |
479 |  |  |  |  | Works exactly as C<like()>, only it checks if $got B<does not> match the
480 |  |  |  |  | given pattern.
481 |  |  |  |  |
482 |  |  |  |  | =cut
483 |  |  |  |  |
484 |  |  |  |  | sub unlike ($$;$) {
485 |  |  |  |  | my $tb = Test::More->builder;
486 |  |  |  |  |
487 |  |  |  |  | return $tb->unlike(@_);
488 |  |  |  |  | }
489 |  |  |  |  |
490 |  |  |  |  | =item B<cmp_ok>
491 |  |  |  |  |
492 |  |  |  |  | cmp_ok( $got, $op, $expected, $test_name );
493 |  |  |  |  |
494 |  |  |  |  | Halfway between C<ok()> and C<is()> lies C<cmp_ok()>. This allows you
495 |  |  |  |  | to compare two arguments using any binary perl operator. The test
496 |  |  |  |  | passes if the comparison is true and fails otherwise.
497 |  |  |  |  |
498 |  |  |  |  | # ok( $got eq $expected );
499 |  |  |  |  | cmp_ok( $got, 'eq', $expected, 'this eq that' );
500 |  |  |  |  |
501 |  |  |  |  | # ok( $got == $expected );
502 |  |  |  |  | cmp_ok( $got, '==', $expected, 'this == that' );
503 |  |  |  |  |
504 |  |  |  |  | # ok( $got && $expected );
505 |  |  |  |  | cmp_ok( $got, '&&', $expected, 'this && that' );
506 |  |  |  |  | ...etc...
507 |  |  |  |  |
508 |  |  |  |  | Its advantage over C<ok()> is when the test fails you'll know what $got
509 |  |  |  |  | and $expected were:
510 |  |  |  |  |
511 |  |  |  |  | not ok 1
512 |  |  |  |  | # Failed test in foo.t at line 12.
513 |  |  |  |  | # '23'
514 |  |  |  |  | # &&
515 |  |  |  |  | # undef
516 |  |  |  |  |
517 |  |  |  |  | It's also useful in those cases where you are comparing numbers and
518 |  |  |  |  | C<is()>'s use of C<eq> will interfere:
519 |  |  |  |  |
520 |  |  |  |  | cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
521 |  |  |  |  |
522 |  |  |  |  | It's especially useful when comparing greater-than or smaller-than
523 |  |  |  |  | relation between values:
524 |  |  |  |  |
525 |  |  |  |  | cmp_ok( $some_value, '<=', $upper_limit );
526 |  |  |  |  |
527 |  |  |  |  |
528 |  |  |  |  | =cut
529 |  |  |  |  |
530 |  |  |  |  | sub cmp_ok($$$;$) {
531 |  |  |  |  | my $tb = Test::More->builder;
532 |  |  |  |  |
533 |  |  |  |  | return $tb->cmp_ok(@_);
534 |  |  |  |  | }
535 |  |  |  |  |
536 |  |  |  |  | =item B<can_ok>
537 |  |  |  |  |
538 |  |  |  |  | can_ok($module, @methods);
539 |  |  |  |  | can_ok($object, @methods);
540 |  |  |  |  |
541 |  |  |  |  | Checks to make sure the $module or $object can do these @methods
542 |  |  |  |  | (works with functions, too).
543 |  |  |  |  |
544 |  |  |  |  | can_ok('Foo', qw(this that whatever));
545 |  |  |  |  |
546 |  |  |  |  | is almost exactly like saying:
547 |  |  |  |  |
548 |  |  |  |  | ok( Foo->can('this') &&
549 |  |  |  |  | Foo->can('that') &&
550 |  |  |  |  | Foo->can('whatever')
551 |  |  |  |  | );
552 |  |  |  |  |
553 |  |  |  |  | only without all the typing and with a better interface. Handy for
554 |  |  |  |  | quickly testing an interface.
555 |  |  |  |  |
556 |  |  |  |  | No matter how many @methods you check, a single C<can_ok()> call counts
557 |  |  |  |  | as one test. If you desire otherwise, use:
558 |  |  |  |  |
559 |  |  |  |  | foreach my $meth (@methods) {
560 |  |  |  |  | can_ok('Foo', $meth);
561 |  |  |  |  | }
562 |  |  |  |  |
563 |  |  |  |  | =cut
564 |  |  |  |  |
565 |  |  |  |  | sub can_ok ($@) {
566 |  |  |  |  | my( $proto, @methods ) = @_;
567 |  |  |  |  | my $class = ref $proto || $proto;
568 |  |  |  |  | my $tb = Test::More->builder;
569 |  |  |  |  |
570 |  |  |  |  | unless($class) {
571 |  |  |  |  | my $ok = $tb->ok( 0, "->can(...)" );
572 |  |  |  |  | $tb->diag(' can_ok() called with empty class or reference');
573 |  |  |  |  | return $ok;
574 |  |  |  |  | }
575 |  |  |  |  |
576 |  |  |  |  | unless(@methods) {
577 |  |  |  |  | my $ok = $tb->ok( 0, "$class->can(...)" );
578 |  |  |  |  | $tb->diag(' can_ok() called with no methods');
579 |  |  |  |  | return $ok;
580 |  |  |  |  | }
581 |  |  |  |  |
582 |  |  |  |  | my @nok = ();
583 |  |  |  |  | foreach my $method (@methods) {
584 |  |  |  |  | $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
585 |  |  |  |  | }
586 |  |  |  |  |
587 |  |  |  |  | my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
588 |  |  |  |  | "$class->can(...)" ;
589 |  |  |  |  |
590 |  |  |  |  | my $ok = $tb->ok( !@nok, $name );
591 |  |  |  |  |
592 |  |  |  |  | $tb->diag( map " $class->can('$_') failed\n", @nok );
593 |  |  |  |  |
594 |  |  |  |  | return $ok;
595 |  |  |  |  | }
596 |  |  |  |  |
597 |  |  |  |  | =item B<isa_ok>
598 |  |  |  |  |
599 |  |  |  |  | isa_ok($object, $class, $object_name);
600 |  |  |  |  | isa_ok($subclass, $class, $object_name);
601 |  |  |  |  | isa_ok($ref, $type, $ref_name);
602 |  |  |  |  |
603 |  |  |  |  | Checks to see if the given C<< $object->isa($class) >>. Also checks to make
604 |  |  |  |  | sure the object was defined in the first place. Handy for this sort
605 |  |  |  |  | of thing:
606 |  |  |  |  |
607 |  |  |  |  | my $obj = Some::Module->new;
608 |  |  |  |  | isa_ok( $obj, 'Some::Module' );
609 |  |  |  |  |
610 |  |  |  |  | where you'd otherwise have to write
611 |  |  |  |  |
612 |  |  |  |  | my $obj = Some::Module->new;
613 |  |  |  |  | ok( defined $obj && $obj->isa('Some::Module') );
614 |  |  |  |  |
615 |  |  |  |  | to safeguard against your test script blowing up.
616 |  |  |  |  |
617 |  |  |  |  | You can also test a class, to make sure that it has the right ancestor:
618 |  |  |  |  |
619 |  |  |  |  | isa_ok( 'Vole', 'Rodent' );
620 |  |  |  |  |
621 |  |  |  |  | It works on references, too:
622 |  |  |  |  |
623 |  |  |  |  | isa_ok( $array_ref, 'ARRAY' );
624 |  |  |  |  |
625 |  |  |  |  | The diagnostics of this test normally just refer to 'the object'. If
626 |  |  |  |  | you'd like them to be more specific, you can supply an $object_name
627 |  |  |  |  | (for example 'Test customer').
628 |  |  |  |  |
629 |  |  |  |  | =cut
630 |  |  |  |  |
631 |  |  |  |  | sub isa_ok ($$;$) {
632 |  |  |  |  | my( $thing, $class, $thing_name ) = @_;
633 |  |  |  |  | my $tb = Test::More->builder;
634 |  |  |  |  |
635 |  |  |  |  | my $whatami;
636 |  |  |  |  | if( !defined $thing ) {
637 |  |  |  |  | $whatami = 'undef';
638 |  |  |  |  | }
639 |  |  |  |  | elsif( ref $thing ) {
640 |  |  |  |  | $whatami = 'reference';
641 |  |  |  |  |
642 |  |  |  |  | local($@,$!);
643 |  |  |  |  | require Scalar::Util;
644 |  |  |  |  | if( Scalar::Util::blessed($thing) ) {
645 |  |  |  |  | $whatami = 'object';
646 |  |  |  |  | }
647 |  |  |  |  | }
648 |  |  |  |  | else {
649 |  |  |  |  | $whatami = 'class';
650 |  |  |  |  | }
651 |  |  |  |  |
652 |  |  |  |  | # We can't use UNIVERSAL::isa because we want to honor isa() overrides
653 |  |  |  |  | my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );
654 |  |  |  |  |
655 |  |  |  |  | if($error) {
656 |  |  |  |  | die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/;
657 |  |  |  |  | WHOA! I tried to call ->isa on your $whatami and got some weird error.
658 |  |  |  |  | Here's the error.
659 |  |  |  |  | $error
660 |  |  |  |  | WHOA
661 |  |  |  |  | }
662 |  |  |  |  |
663 |  |  |  |  | # Special case for isa_ok( [], "ARRAY" ) and like
664 |  |  |  |  | if( $whatami eq 'reference' ) {
665 |  |  |  |  | $rslt = UNIVERSAL::isa($thing, $class);
666 |  |  |  |  | }
667 |  |  |  |  |
668 |  |  |  |  | my($diag, $name);
669 |  |  |  |  | if( defined $thing_name ) {
670 |  |  |  |  | $name = "'$thing_name' isa '$class'";
671 |  |  |  |  | $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
672 |  |  |  |  | }
673 |  |  |  |  | elsif( $whatami eq 'object' ) {
674 |  |  |  |  | my $my_class = ref $thing;
675 |  |  |  |  | $thing_name = qq[An object of class '$my_class'];
676 |  |  |  |  | $name = "$thing_name isa '$class'";
677 |  |  |  |  | $diag = "The object of class '$my_class' isn't a '$class'";
678 |  |  |  |  | }
679 |  |  |  |  | elsif( $whatami eq 'reference' ) {
680 |  |  |  |  | my $type = ref $thing;
681 |  |  |  |  | $thing_name = qq[A reference of type '$type'];
682 |  |  |  |  | $name = "$thing_name isa '$class'";
683 |  |  |  |  | $diag = "The reference of type '$type' isn't a '$class'";
684 |  |  |  |  | }
685 |  |  |  |  | elsif( $whatami eq 'undef' ) {
686 |  |  |  |  | $thing_name = 'undef';
687 |  |  |  |  | $name = "$thing_name isa '$class'";
688 |  |  |  |  | $diag = "$thing_name isn't defined";
689 |  |  |  |  | }
690 |  |  |  |  | elsif( $whatami eq 'class' ) {
691 |  |  |  |  | $thing_name = qq[The class (or class-like) '$thing'];
692 |  |  |  |  | $name = "$thing_name isa '$class'";
693 |  |  |  |  | $diag = "$thing_name isn't a '$class'";
694 |  |  |  |  | }
695 |  |  |  |  | else {
696 |  |  |  |  | die;
697 |  |  |  |  | }
698 |  |  |  |  |
699 |  |  |  |  | my $ok;
700 |  |  |  |  | if($rslt) {
701 |  |  |  |  | $ok = $tb->ok( 1, $name );
702 |  |  |  |  | }
703 |  |  |  |  | else {
704 |  |  |  |  | $ok = $tb->ok( 0, $name );
705 |  |  |  |  | $tb->diag(" $diag\n");
706 |  |  |  |  | }
707 |  |  |  |  |
708 |  |  |  |  | return $ok;
709 |  |  |  |  | }
710 |  |  |  |  |
711 |  |  |  |  | =item B<new_ok>
712 |  |  |  |  |
713 |  |  |  |  | my $obj = new_ok( $class );
714 |  |  |  |  | my $obj = new_ok( $class => \@args );
715 |  |  |  |  | my $obj = new_ok( $class => \@args, $object_name );
716 |  |  |  |  |
717 |  |  |  |  | A convenience function which combines creating an object and calling
718 |  |  |  |  | C<isa_ok()> on that object.
719 |  |  |  |  |
720 |  |  |  |  | It is basically equivalent to:
721 |  |  |  |  |
722 |  |  |  |  | my $obj = $class->new(@args);
723 |  |  |  |  | isa_ok $obj, $class, $object_name;
724 |  |  |  |  |
725 |  |  |  |  | If @args is not given, an empty list will be used.
726 |  |  |  |  |
727 |  |  |  |  | This function only works on C<new()> and it assumes C<new()> will return
728 |  |  |  |  | just a single object which isa C<$class>.
729 |  |  |  |  |
730 |  |  |  |  | =cut
731 |  |  |  |  |
732 |  |  |  |  | sub new_ok {
733 |  |  |  |  | my $tb = Test::More->builder;
734 |  |  |  |  | $tb->croak("new_ok() must be given at least a class") unless @_;
735 |  |  |  |  |
736 |  |  |  |  | my( $class, $args, $object_name ) = @_;
737 |  |  |  |  |
738 |  |  |  |  | $args ||= [];
739 |  |  |  |  |
740 |  |  |  |  | my $obj;
741 |  |  |  |  | my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
742 |  |  |  |  | if($success) {
743 |  |  |  |  | local $Test::Builder::Level = $Test::Builder::Level + 1;
744 |  |  |  |  | isa_ok $obj, $class, $object_name;
745 |  |  |  |  | }
746 |  |  |  |  | else {
747 |  |  |  |  | $class = 'undef' if !defined $class;
748 |  |  |  |  | $tb->ok( 0, "$class->new() died" );
749 |  |  |  |  | $tb->diag(" Error was: $error");
750 |  |  |  |  | }
751 |  |  |  |  |
752 |  |  |  |  | return $obj;
753 |  |  |  |  | }
754 |  |  |  |  |
755 |  |  |  |  | =item B<subtest>
756 |  |  |  |  |
757 |  |  |  |  | subtest $name => \&code, @args;
758 |  |  |  |  |
759 |  |  |  |  | C<subtest()> runs the &code as its own little test with its own plan and
760 |  |  |  |  | its own result. The main test counts this as a single test using the
761 |  |  |  |  | result of the whole subtest to determine if its ok or not ok.
762 |  |  |  |  |
763 |  |  |  |  | For example...
764 |  |  |  |  |
765 |  |  |  |  | use Test::More tests => 3;
766 |  |  |  |  |
767 |  |  |  |  | pass("First test");
768 |  |  |  |  |
769 |  |  |  |  | subtest 'An example subtest' => sub {
770 |  |  |  |  | plan tests => 2;
771 |  |  |  |  |
772 |  |  |  |  | pass("This is a subtest");
773 |  |  |  |  | pass("So is this");
774 |  |  |  |  | };
775 |  |  |  |  |
776 |  |  |  |  | pass("Third test");
777 |  |  |  |  |
778 |  |  |  |  | This would produce.
779 |  |  |  |  |
780 |  |  |  |  | 1..3
781 |  |  |  |  | ok 1 - First test
782 |  |  |  |  | # Subtest: An example subtest
783 |  |  |  |  | 1..2
784 |  |  |  |  | ok 1 - This is a subtest
785 |  |  |  |  | ok 2 - So is this
786 |  |  |  |  | ok 2 - An example subtest
787 |  |  |  |  | ok 3 - Third test
788 |  |  |  |  |
789 |  |  |  |  | A subtest may call C<skip_all>. No tests will be run, but the subtest is
790 |  |  |  |  | considered a skip.
791 |  |  |  |  |
792 |  |  |  |  | subtest 'skippy' => sub {
793 |  |  |  |  | plan skip_all => 'cuz I said so';
794 |  |  |  |  | pass('this test will never be run');
795 |  |  |  |  | };
796 |  |  |  |  |
797 |  |  |  |  | Returns true if the subtest passed, false otherwise.
798 |  |  |  |  |
799 |  |  |  |  | Due to how subtests work, you may omit a plan if you desire. This adds an
800 |  |  |  |  | implicit C<done_testing()> to the end of your subtest. The following two
801 |  |  |  |  | subtests are equivalent:
802 |  |  |  |  |
803 |  |  |  |  | subtest 'subtest with implicit done_testing()', sub {
804 |  |  |  |  | ok 1, 'subtests with an implicit done testing should work';
805 |  |  |  |  | ok 1, '... and support more than one test';
806 |  |  |  |  | ok 1, '... no matter how many tests are run';
807 |  |  |  |  | };
808 |  |  |  |  |
809 |  |  |  |  | subtest 'subtest with explicit done_testing()', sub {
810 |  |  |  |  | ok 1, 'subtests with an explicit done testing should work';
811 |  |  |  |  | ok 1, '... and support more than one test';
812 |  |  |  |  | ok 1, '... no matter how many tests are run';
813 |  |  |  |  | done_testing();
814 |  |  |  |  | };
815 |  |  |  |  |
816 |  |  |  |  | Extra arguments given to C<subtest> are passed to the callback. For example:
817 |  |  |  |  |
818 |  |  |  |  | sub my_subtest {
819 |  |  |  |  | my $range = shift;
820 |  |  |  |  | ...
821 |  |  |  |  | }
822 |  |  |  |  |
823 |  |  |  |  | for my $range (1, 10, 100, 1000) {
824 |  |  |  |  | subtest "testing range $range", \&my_subtest, $range;
825 |  |  |  |  | }
826 |  |  |  |  |
827 |  |  |  |  | =cut
828 |  |  |  |  |
829 |  |  |  |  | sub subtest {
830 |  |  |  |  | my $tb = Test::More->builder;
831 |  |  |  |  | return $tb->subtest(@_);
832 |  |  |  |  | }
833 |  |  |  |  |
834 |  |  |  |  | =item B<pass>
835 |  |  |  |  |
836 |  |  |  |  | =item B<fail>
837 |  |  |  |  |
838 |  |  |  |  | pass($test_name);
839 |  |  |  |  | fail($test_name);
840 |  |  |  |  |
841 |  |  |  |  | Sometimes you just want to say that the tests have passed. Usually
842 |  |  |  |  | the case is you've got some complicated condition that is difficult to
843 |  |  |  |  | wedge into an C<ok()>. In this case, you can simply use C<pass()> (to
844 |  |  |  |  | declare the test ok) or fail (for not ok). They are synonyms for
845 |  |  |  |  | C<ok(1)> and C<ok(0)>.
846 |  |  |  |  |
847 |  |  |  |  | Use these very, very, very sparingly.
848 |  |  |  |  |
849 |  |  |  |  | =cut
850 |  |  |  |  |
851 |  |  |  |  | sub pass (;$) {
852 |  |  |  |  | my $tb = Test::More->builder;
853 |  |  |  |  |
854 |  |  |  |  | return $tb->ok( 1, @_ );
855 |  |  |  |  | }
856 |  |  |  |  |
857 |  |  |  |  | sub fail (;$) {
858 |  |  |  |  | my $tb = Test::More->builder;
859 |  |  |  |  |
860 |  |  |  |  | return $tb->ok( 0, @_ );
861 |  |  |  |  | }
862 |  |  |  |  |
863 |  |  |  |  | =back
864 |  |  |  |  |
865 |  |  |  |  |
866 |  |  |  |  | =head2 Module tests
867 |  |  |  |  |
868 |  |  |  |  | Sometimes you want to test if a module, or a list of modules, can
869 |  |  |  |  | successfully load. For example, you'll often want a first test which
870 |  |  |  |  | simply loads all the modules in the distribution to make sure they
871 |  |  |  |  | work before going on to do more complicated testing.
872 |  |  |  |  |
873 |  |  |  |  | For such purposes we have C<use_ok> and C<require_ok>.
874 |  |  |  |  |
875 |  |  |  |  | =over 4
876 |  |  |  |  |
877 |  |  |  |  | =item B<require_ok>
878 |  |  |  |  |
879 |  |  |  |  | require_ok($module);
880 |  |  |  |  | require_ok($file);
881 |  |  |  |  |
882 |  |  |  |  | Tries to C<require> the given $module or $file. If it loads
883 |  |  |  |  | successfully, the test will pass. Otherwise it fails and displays the
884 |  |  |  |  | load error.
885 |  |  |  |  |
886 |  |  |  |  | C<require_ok> will guess whether the input is a module name or a
887 |  |  |  |  | filename.
888 |  |  |  |  |
889 |  |  |  |  | No exception will be thrown if the load fails.
890 |  |  |  |  |
891 |  |  |  |  | # require Some::Module
892 |  |  |  |  | require_ok "Some::Module";
893 |  |  |  |  |
894 |  |  |  |  | # require "Some/File.pl";
895 |  |  |  |  | require_ok "Some/File.pl";
896 |  |  |  |  |
897 |  |  |  |  | # stop testing if any of your modules will not load
898 |  |  |  |  | for my $module (@module) {
899 |  |  |  |  | require_ok $module or BAIL_OUT "Can't load $module";
900 |  |  |  |  | }
901 |  |  |  |  |
902 |  |  |  |  | =cut
903 |  |  |  |  |
904 |  |  |  |  | sub require_ok ($) {
905 |  |  |  |  | my($module) = shift;
906 |  |  |  |  | my $tb = Test::More->builder;
907 |  |  |  |  |
908 |  |  |  |  | my $pack = caller;
909 |  |  |  |  |
910 |  |  |  |  | # Try to determine if we've been given a module name or file.
911 |  |  |  |  | # Module names must be barewords, files not.
912 |  |  |  |  | $module = qq['$module'] unless _is_module_name($module);
913 |  |  |  |  |
914 |  |  |  |  | my $code = <<REQUIRE;
915 |  |  |  |  | package $pack;
916 |  |  |  |  | require $module;
917 |  |  |  |  | 1;
918 |  |  |  |  | REQUIRE
919 |  |  |  |  |
920 |  |  |  |  | my( $eval_result, $eval_error ) = _eval($code);
921 |  |  |  |  | my $ok = $tb->ok( $eval_result, "require $module;" );
922 |  |  |  |  |
923 |  |  |  |  | unless($ok) {
924 |  |  |  |  | chomp $eval_error;
925 |  |  |  |  | $tb->diag(<<DIAGNOSTIC);
926 |  |  |  |  | Tried to require '$module'.
927 |  |  |  |  | Error: $eval_error
928 |  |  |  |  | DIAGNOSTIC
929 |  |  |  |  |
930 |  |  |  |  | }
931 |  |  |  |  |
932 |  |  |  |  | return $ok;
933 |  |  |  |  | }
934 |  |  |  |  |
935 |  |  |  |  | sub _is_module_name {
936 |  |  |  |  | my $module = shift;
937 |  |  |  |  |
938 |  |  |  |  | # Module names start with a letter.
939 |  |  |  |  | # End with an alphanumeric.
940 |  |  |  |  | # The rest is an alphanumeric or ::
941 |  |  |  |  | $module =~ s/\b::\b//g;
942 |  |  |  |  |
943 |  |  |  |  | return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
944 |  |  |  |  | }
945 |  |  |  |  |
946 |  |  |  |  |
947 |  |  |  |  | =item B<use_ok>
948 |  |  |  |  |
949 |  |  |  |  | BEGIN { use_ok($module); }
950 |  |  |  |  | BEGIN { use_ok($module, @imports); }
951 |  |  |  |  |
952 |  |  |  |  | Like C<require_ok>, but it will C<use> the $module in question and
953 |  |  |  |  | only loads modules, not files.
954 |  |  |  |  |
955 |  |  |  |  | If you just want to test a module can be loaded, use C<require_ok>.
956 |  |  |  |  |
957 |  |  |  |  | If you just want to load a module in a test, we recommend simply using
958 |  |  |  |  | C<use> directly. It will cause the test to stop.
959 |  |  |  |  |
960 |  |  |  |  | It's recommended that you run C<use_ok()> inside a BEGIN block so its
961 |  |  |  |  | functions are exported at compile-time and prototypes are properly
962 |  |  |  |  | honored.
963 |  |  |  |  |
964 |  |  |  |  | If @imports are given, they are passed through to the use. So this:
965 |  |  |  |  |
966 |  |  |  |  | BEGIN { use_ok('Some::Module', qw(foo bar)) }
967 |  |  |  |  |
968 |  |  |  |  | is like doing this:
969 |  |  |  |  |
970 |  |  |  |  | use Some::Module qw(foo bar);
971 |  |  |  |  |
972 |  |  |  |  | Version numbers can be checked like so:
973 |  |  |  |  |
974 |  |  |  |  | # Just like "use Some::Module 1.02"
975 |  |  |  |  | BEGIN { use_ok('Some::Module', 1.02) }
976 |  |  |  |  |
977 |  |  |  |  | Don't try to do this:
978 |  |  |  |  |
979 |  |  |  |  | BEGIN {
980 |  |  |  |  | use_ok('Some::Module');
981 |  |  |  |  |
982 |  |  |  |  | ...some code that depends on the use...
983 |  |  |  |  | ...happening at compile time...
984 |  |  |  |  | }
985 |  |  |  |  |
986 |  |  |  |  | because the notion of "compile-time" is relative. Instead, you want:
987 |  |  |  |  |
988 |  |  |  |  | BEGIN { use_ok('Some::Module') }
989 |  |  |  |  | BEGIN { ...some code that depends on the use... }
990 |  |  |  |  |
991 |  |  |  |  | If you want the equivalent of C<use Foo ()>, use a module but not
992 |  |  |  |  | import anything, use C<require_ok>.
993 |  |  |  |  |
994 |  |  |  |  | BEGIN { require_ok "Foo" }
995 |  |  |  |  |
996 |  |  |  |  | =cut
997 |  |  |  |  |
998 |  |  |  |  | sub use_ok ($;@) {
999 |  |  |  |  | my( $module, @imports ) = @_;
1000 |  |  |  |  | @imports = () unless @imports;
1001 |  |  |  |  | my $tb = Test::More->builder;
1002 |  |  |  |  |
1003 |  |  |  |  | my %caller;
1004 |  |  |  |  | @caller{qw/pack file line sub args want eval req strict warn/} = caller(0);
1005 |  |  |  |  |
1006 |  |  |  |  | my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/};
1007 |  |  |  |  | $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
1008 |  |  |  |  |
1009 |  |  |  |  | my $code;
1010 |  |  |  |  | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
1011 |  |  |  |  | # probably a version check. Perl needs to see the bare number
1012 |  |  |  |  | # for it to work with non-Exporter based modules.
1013 |  |  |  |  | $code = <<USE;
1014 |  |  |  |  | package $pack;
1015 |  |  |  |  | BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] }
1016 |  |  |  |  | #line $line $filename
1017 |  |  |  |  | use $module $imports[0];
1018 |  |  |  |  | 1;
1019 |  |  |  |  | USE
1020 |  |  |  |  | }
1021 |  |  |  |  | else {
1022 |  |  |  |  | $code = <<USE;
1023 |  |  |  |  | package $pack;
1024 |  |  |  |  | BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] }
1025 |  |  |  |  | #line $line $filename
1026 |  |  |  |  | use $module \@{\$args[0]};
1027 |  |  |  |  | 1;
1028 |  |  |  |  | USE
1029 |  |  |  |  | }
1030 |  |  |  |  |
1031 |  |  |  |  | my ($eval_result, $eval_error) = _eval($code, \@imports, $warn);
1032 |  |  |  |  | my $ok = $tb->ok( $eval_result, "use $module;" );
1033 |  |  |  |  |
1034 |  |  |  |  | unless($ok) {
1035 |  |  |  |  | chomp $eval_error;
1036 |  |  |  |  | $@ =~ s{^BEGIN failed--compilation aborted at .*$}
1037 |  |  |  |  | {BEGIN failed--compilation aborted at $filename line $line.}m;
1038 |  |  |  |  | $tb->diag(<<DIAGNOSTIC);
1039 |  |  |  |  | Tried to use '$module'.
1040 |  |  |  |  | Error: $eval_error
1041 |  |  |  |  | DIAGNOSTIC
1042 |  |  |  |  |
1043 |  |  |  |  | }
1044 |  |  |  |  |
1045 |  |  |  |  | return $ok;
1046 |  |  |  |  | }
1047 |  |  |  |  |
1048 |  |  |  |  | sub _eval {
1049 |  |  |  |  | my( $code, @args ) = @_;
1050 |  |  |  |  |
1051 |  |  |  |  | # Work around oddities surrounding resetting of $@ by immediately
1052 |  |  |  |  | # storing it.
1053 |  |  |  |  | my( $sigdie, $eval_result, $eval_error );
1054 |  |  |  |  | {
1055 |  |  |  |  | local( $@, $!, $SIG{__DIE__} ); # isolate eval
1056 |  |  |  |  | $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
1057 |  |  |  |  | $eval_error = $@;
1058 |  |  |  |  | $sigdie = $SIG{__DIE__} || undef;
1059 |  |  |  |  | }
1060 |  |  |  |  | # make sure that $code got a chance to set $SIG{__DIE__}
1061 |  |  |  |  | $SIG{__DIE__} = $sigdie if defined $sigdie;
1062 |  |  |  |  |
1063 |  |  |  |  | return( $eval_result, $eval_error );
1064 |  |  |  |  | }
1065 |  |  |  |  |
1066 |  |  |  |  |
1067 |  |  |  |  | =back
1068 |  |  |  |  |
1069 |  |  |  |  |
1070 |  |  |  |  | =head2 Complex data structures
1071 |  |  |  |  |
1072 |  |  |  |  | Not everything is a simple eq check or regex. There are times you
1073 |  |  |  |  | need to see if two data structures are equivalent. For these
1074 |  |  |  |  | instances Test::More provides a handful of useful functions.
1075 |  |  |  |  |
1076 |  |  |  |  | B<NOTE> I'm not quite sure what will happen with filehandles.
1077 |  |  |  |  |
1078 |  |  |  |  | =over 4
1079 |  |  |  |  |
1080 |  |  |  |  | =item B<is_deeply>
1081 |  |  |  |  |
1082 |  |  |  |  | is_deeply( $got, $expected, $test_name );
1083 |  |  |  |  |
1084 |  |  |  |  | Similar to C<is()>, except that if $got and $expected are references, it
1085 |  |  |  |  | does a deep comparison walking each data structure to see if they are
1086 |  |  |  |  | equivalent. If the two structures are different, it will display the
1087 |  |  |  |  | place where they start differing.
1088 |  |  |  |  |
1089 |  |  |  |  | C<is_deeply()> compares the dereferenced values of references, the
1090 |  |  |  |  | references themselves (except for their type) are ignored. This means
1091 |  |  |  |  | aspects such as blessing and ties are not considered "different".
1092 |  |  |  |  |
1093 |  |  |  |  | C<is_deeply()> currently has very limited handling of function reference
1094 |  |  |  |  | and globs. It merely checks if they have the same referent. This may
1095 |  |  |  |  | improve in the future.
1096 |  |  |  |  |
1097 |  |  |  |  | L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
1098 |  |  |  |  | along these lines.
1099 |  |  |  |  |
1100 |  |  |  |  | B<NOTE> is_deeply() has limitations when it comes to comparing strings and
1101 |  |  |  |  | refs:
1102 |  |  |  |  |
1103 |  |  |  |  | my $path = path('.');
1104 |  |  |  |  | my $hash = {};
1105 |  |  |  |  | is_deeply( $path, "$path" ); # ok
1106 |  |  |  |  | is_deeply( $hash, "$hash" ); # fail
1107 |  |  |  |  |
1108 |  |  |  |  | This happens because is_deeply will unoverload all arguments unconditionally.
1109 |  |  |  |  | It is probably best not to use is_deeply with overloading. For legacy reasons
1110 |  |  |  |  | this is not likely to ever be fixed. If you would like a much better tool for
1111 |  |  |  |  | this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has
1112 |  |  |  |  | an C<is()> function that works like C<is_deeply> with many improvements.
1113 |  |  |  |  |
1114 |  |  |  |  | =cut
1115 |  |  |  |  |
1116 |  |  |  |  | our( @Data_Stack, %Refs_Seen );
1117 | 1 | 3µs |  |  | my $DNE = bless [], 'Does::Not::Exist';
1118 |  |  |  |  |
1119 |  |  |  |  | sub _dne {
1120 |  |  |  |  | return ref $_[0] eq ref $DNE;
1121 |  |  |  |  | }
1122 |  |  |  |  |
1123 |  |  |  |  | ## no critic (Subroutines::RequireArgUnpacking)
1124 |  |  |  |  | sub is_deeply {
1125 |  |  |  |  | my $tb = Test::More->builder;
1126 |  |  |  |  |
1127 |  |  |  |  | unless( @_ == 2 or @_ == 3 ) {
1128 |  |  |  |  | my $msg = <<'WARNING';
1129 |  |  |  |  | is_deeply() takes two or three args, you gave %d.
1130 |  |  |  |  | This usually means you passed an array or hash instead
1131 |  |  |  |  | of a reference to it
1132 |  |  |  |  | WARNING
1133 |  |  |  |  | chop $msg; # clip off newline so carp() will put in line/file
1134 |  |  |  |  |
1135 |  |  |  |  | _carp sprintf $msg, scalar @_;
1136 |  |  |  |  |
1137 |  |  |  |  | return $tb->ok(0);
1138 |  |  |  |  | }
1139 |  |  |  |  |
1140 |  |  |  |  | my( $got, $expected, $name ) = @_;
1141 |  |  |  |  |
1142 |  |  |  |  | $tb->_unoverload_str( \$expected, \$got );
1143 |  |  |  |  |
1144 |  |  |  |  | my $ok;
1145 |  |  |  |  | if( !ref $got and !ref $expected ) { # neither is a reference
1146 |  |  |  |  | $ok = $tb->is_eq( $got, $expected, $name );
1147 |  |  |  |  | }
1148 |  |  |  |  | elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
1149 |  |  |  |  | $ok = $tb->ok( 0, $name );
1150 |  |  |  |  | $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
1151 |  |  |  |  | }
1152 |  |  |  |  | else { # both references
1153 |  |  |  |  | local @Data_Stack = ();
1154 |  |  |  |  | if( _deep_check( $got, $expected ) ) {
1155 |  |  |  |  | $ok = $tb->ok( 1, $name );
1156 |  |  |  |  | }
1157 |  |  |  |  | else {
1158 |  |  |  |  | $ok = $tb->ok( 0, $name );
1159 |  |  |  |  | $tb->diag( _format_stack(@Data_Stack) );
1160 |  |  |  |  | }
1161 |  |  |  |  | }
1162 |  |  |  |  |
1163 |  |  |  |  | return $ok;
1164 |  |  |  |  | }
1165 |  |  |  |  |
1166 |  |  |  |  | sub _format_stack {
1167 |  |  |  |  | my(@Stack) = @_;
1168 |  |  |  |  |
1169 |  |  |  |  | my $var = '$FOO';
1170 |  |  |  |  | my $did_arrow = 0;
1171 |  |  |  |  | foreach my $entry (@Stack) {
1172 |  |  |  |  | my $type = $entry->{type} || '';
1173 |  |  |  |  | my $idx = $entry->{'idx'};
1174 |  |  |  |  | if( $type eq 'HASH' ) {
1175 |  |  |  |  | $var .= "->" unless $did_arrow++;
1176 |  |  |  |  | $var .= "{$idx}";
1177 |  |  |  |  | }
1178 |  |  |  |  | elsif( $type eq 'ARRAY' ) {
1179 |  |  |  |  | $var .= "->" unless $did_arrow++;
1180 |  |  |  |  | $var .= "[$idx]";
1181 |  |  |  |  | }
1182 |  |  |  |  | elsif( $type eq 'REF' ) {
1183 |  |  |  |  | $var = "\${$var}";
1184 |  |  |  |  | }
1185 |  |  |  |  | }
1186 |  |  |  |  |
1187 |  |  |  |  | my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
1188 |  |  |  |  | my @vars = ();
1189 |  |  |  |  | ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
1190 |  |  |  |  | ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
1191 |  |  |  |  |
1192 |  |  |  |  | my $out = "Structures begin differing at:\n";
1193 |  |  |  |  | foreach my $idx ( 0 .. $#vals ) {
1194 |  |  |  |  | my $val = $vals[$idx];
1195 |  |  |  |  | $vals[$idx]
1196 |  |  |  |  | = !defined $val ? 'undef'
1197 |  |  |  |  | : _dne($val) ? "Does not exist"
1198 |  |  |  |  | : ref $val ? "$val"
1199 |  |  |  |  | : "'$val'";
1200 |  |  |  |  | }
1201 |  |  |  |  |
1202 |  |  |  |  | $out .= "$vars[0] = $vals[0]\n";
1203 |  |  |  |  | $out .= "$vars[1] = $vals[1]\n";
1204 |  |  |  |  |
1205 |  |  |  |  | $out =~ s/^/ /msg;
1206 |  |  |  |  | return $out;
1207 |  |  |  |  | }
1208 |  |  |  |  |
1209 | 1 | 4µs |  |  | my %_types = (
1210 |  |  |  |  | (map +($_ => $_), qw(
1211 |  |  |  |  | Regexp
1212 |  |  |  |  | ARRAY
1213 |  |  |  |  | HASH
1214 |  |  |  |  | SCALAR
1215 |  |  |  |  | REF
1216 |  |  |  |  | GLOB
1217 |  |  |  |  | CODE
1218 |  |  |  |  | )),
1219 |  |  |  |  | 'LVALUE' => 'SCALAR',
1220 |  |  |  |  | 'REF' => 'SCALAR',
1221 |  |  |  |  | 'VSTRING' => 'SCALAR',
1222 |  |  |  |  | );
1223 |  |  |  |  |
1224 |  |  |  |  | sub _type {
1225 |  |  |  |  | my $thing = shift;
1226 |  |  |  |  |
1227 |  |  |  |  | return '' if !ref $thing;
1228 |  |  |  |  |
1229 |  |  |  |  | for my $type (keys %_types) {
1230 |  |  |  |  | return $_types{$type} if UNIVERSAL::isa( $thing, $type );
1231 |  |  |  |  | }
1232 |  |  |  |  |
1233 |  |  |  |  | return '';
1234 |  |  |  |  | }
1235 |  |  |  |  |
1236 |  |  |  |  | =back
1237 |  |  |  |  |
1238 |  |  |  |  |
1239 |  |  |  |  | =head2 Diagnostics
1240 |  |  |  |  |
1241 |  |  |  |  | If you pick the right test function, you'll usually get a good idea of
1242 |  |  |  |  | what went wrong when it failed. But sometimes it doesn't work out
1243 |  |  |  |  | that way. So here we have ways for you to write your own diagnostic
1244 |  |  |  |  | messages which are safer than just C<print STDERR>.
1245 |  |  |  |  |
1246 |  |  |  |  | =over 4
1247 |  |  |  |  |
1248 |  |  |  |  | =item B<diag>
1249 |  |  |  |  |
1250 |  |  |  |  | diag(@diagnostic_message);
1251 |  |  |  |  |
1252 |  |  |  |  | Prints a diagnostic message which is guaranteed not to interfere with
1253 |  |  |  |  | test output. Like C<print> @diagnostic_message is simply concatenated
1254 |  |  |  |  | together.
1255 |  |  |  |  |
1256 |  |  |  |  | Returns false, so as to preserve failure.
1257 |  |  |  |  |
1258 |  |  |  |  | Handy for this sort of thing:
1259 |  |  |  |  |
1260 |  |  |  |  | ok( grep(/foo/, @users), "There's a foo user" ) or
1261 |  |  |  |  | diag("Since there's no foo, check that /etc/bar is set up right");
1262 |  |  |  |  |
1263 |  |  |  |  | which would produce:
1264 |  |  |  |  |
1265 |  |  |  |  | not ok 42 - There's a foo user
1266 |  |  |  |  | # Failed test 'There's a foo user'
1267 |  |  |  |  | # in foo.t at line 52.
1268 |  |  |  |  | # Since there's no foo, check that /etc/bar is set up right.
1269 |  |  |  |  |
1270 |  |  |  |  | You might remember C<ok() or diag()> with the mnemonic C<open() or
1271 |  |  |  |  | die()>.
1272 |  |  |  |  |
1273 |  |  |  |  | B<NOTE> The exact formatting of the diagnostic output is still
1274 |  |  |  |  | changing, but it is guaranteed that whatever you throw at it won't
1275 |  |  |  |  | interfere with the test.
1276 |  |  |  |  |
1277 |  |  |  |  | =item B<note>
1278 |  |  |  |  |
1279 |  |  |  |  | note(@diagnostic_message);
1280 |  |  |  |  |
1281 |  |  |  |  | Like C<diag()>, except the message will not be seen when the test is run
1282 |  |  |  |  | in a harness. It will only be visible in the verbose TAP stream.
1283 |  |  |  |  |
1284 |  |  |  |  | Handy for putting in notes which might be useful for debugging, but
1285 |  |  |  |  | don't indicate a problem.
1286 |  |  |  |  |
1287 |  |  |  |  | note("Tempfile is $tempfile");
1288 |  |  |  |  |
1289 |  |  |  |  | =cut
1290 |  |  |  |  |
1291 |  |  |  |  | sub diag {
1292 |  |  |  |  | return Test::More->builder->diag(@_);
1293 |  |  |  |  | }
1294 |  |  |  |  |
1295 |  |  |  |  | sub note {
1296 |  |  |  |  | return Test::More->builder->note(@_);
1297 |  |  |  |  | }
1298 |  |  |  |  |
1299 |  |  |  |  | =item B<explain>
1300 |  |  |  |  |
1301 |  |  |  |  | my @dump = explain @diagnostic_message;
1302 |  |  |  |  |
1303 |  |  |  |  | Will dump the contents of any references in a human readable format.
1304 |  |  |  |  | Usually you want to pass this into C<note> or C<diag>.
1305 |  |  |  |  |
1306 |  |  |  |  | Handy for things like...
1307 |  |  |  |  |
1308 |  |  |  |  | is_deeply($have, $want) || diag explain $have;
1309 |  |  |  |  |
1310 |  |  |  |  | or
1311 |  |  |  |  |
1312 |  |  |  |  | note explain \%args;
1313 |  |  |  |  | Some::Class->method(%args);
1314 |  |  |  |  |
1315 |  |  |  |  | =cut
1316 |  |  |  |  |
1317 |  |  |  |  | sub explain {
1318 |  |  |  |  | return Test::More->builder->explain(@_);
1319 |  |  |  |  | }
1320 |  |  |  |  |
1321 |  |  |  |  | =back
1322 |  |  |  |  |
1323 |  |  |  |  |
1324 |  |  |  |  | =head2 Conditional tests
1325 |  |  |  |  |
1326 |  |  |  |  | Sometimes running a test under certain conditions will cause the
1327 |  |  |  |  | test script to die. A certain function or method isn't implemented
1328 |  |  |  |  | (such as C<fork()> on MacOS), some resource isn't available (like a
1329 |  |  |  |  | net connection) or a module isn't available. In these cases it's
1330 |  |  |  |  | necessary to skip tests, or declare that they are supposed to fail
1331 |  |  |  |  | but will work in the future (a todo test).
1332 |  |  |  |  |
1333 |  |  |  |  | For more details on the mechanics of skip and todo tests see
1334 |  |  |  |  | L<Test::Harness>.
1335 |  |  |  |  |
1336 |  |  |  |  | The way Test::More handles this is with a named block. Basically, a
1337 |  |  |  |  | block of tests which can be skipped over or made todo. It's best if I
1338 |  |  |  |  | just show you...
1339 |  |  |  |  |
1340 |  |  |  |  | =over 4
1341 |  |  |  |  |
1342 |  |  |  |  | =item B<SKIP: BLOCK>
1343 |  |  |  |  |
1344 |  |  |  |  | SKIP: {
1345 |  |  |  |  | skip $why, $how_many if $condition;
1346 |  |  |  |  |
1347 |  |  |  |  | ...normal testing code goes here...
1348 |  |  |  |  | }
1349 |  |  |  |  |
1350 |  |  |  |  | This declares a block of tests that might be skipped, $how_many tests
1351 |  |  |  |  | there are, $why and under what $condition to skip them. An example is
1352 |  |  |  |  | the easiest way to illustrate:
1353 |  |  |  |  |
1354 |  |  |  |  | SKIP: {
1355 |  |  |  |  | eval { require HTML::Lint };
1356 |  |  |  |  |
1357 |  |  |  |  | skip "HTML::Lint not installed", 2 if $@;
1358 |  |  |  |  |
1359 |  |  |  |  | my $lint = new HTML::Lint;
1360 |  |  |  |  | isa_ok( $lint, "HTML::Lint" );
1361 |  |  |  |  |
1362 |  |  |  |  | $lint->parse( $html );
1363 |  |  |  |  | is( $lint->errors, 0, "No errors found in HTML" );
1364 |  |  |  |  | }
1365 |  |  |  |  |
1366 |  |  |  |  | If the user does not have HTML::Lint installed, the whole block of
1367 |  |  |  |  | code I<won't be run at all>. Test::More will output special ok's
1368 |  |  |  |  | which Test::Harness interprets as skipped, but passing, tests.
1369 |  |  |  |  |
1370 |  |  |  |  | It's important that $how_many accurately reflects the number of tests
1371 |  |  |  |  | in the SKIP block so the # of tests run will match up with your plan.
1372 |  |  |  |  | If your plan is C<no_plan> $how_many is optional and will default to 1.
1373 |  |  |  |  |
1374 |  |  |  |  | It's perfectly safe to nest SKIP blocks. Each SKIP block must have
1375 |  |  |  |  | the label C<SKIP>, or Test::More can't work its magic.
1376 |  |  |  |  |
1377 |  |  |  |  | You don't skip tests which are failing because there's a bug in your
1378 |  |  |  |  | program, or for which you don't yet have code written. For that you
1379 |  |  |  |  | use TODO. Read on.
1380 |  |  |  |  |
1381 |  |  |  |  | =cut
1382 |  |  |  |  |
1383 |  |  |  |  | ## no critic (Subroutines::RequireFinalReturn)
1384 |  |  |  |  | sub skip {
1385 |  |  |  |  | my( $why, $how_many ) = @_;
1386 |  |  |  |  | my $tb = Test::More->builder;
1387 |  |  |  |  |
1388 |  |  |  |  | # If the plan is set, and is static, then skip needs a count. If the plan
1389 |  |  |  |  | # is 'no_plan' we are fine. As well if plan is undefined then we are
1390 |  |  |  |  | # waiting for done_testing.
1391 |  |  |  |  | unless (defined $how_many) {
1392 |  |  |  |  | my $plan = $tb->has_plan;
1393 |  |  |  |  | _carp "skip() needs to know \$how_many tests are in the block"
1394 |  |  |  |  | if $plan && $plan =~ m/^\d+$/;
1395 |  |  |  |  | $how_many = 1;
1396 |  |  |  |  | }
1397 |  |  |  |  |
1398 |  |  |  |  | if( defined $how_many and $how_many =~ /\D/ ) {
1399 |  |  |  |  | _carp
1400 |  |  |  |  | "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
1401 |  |  |  |  | $how_many = 1;
1402 |  |  |  |  | }
1403 |  |  |  |  |
1404 |  |  |  |  | for( 1 .. $how_many ) {
1405 |  |  |  |  | $tb->skip($why);
1406 |  |  |  |  | }
1407 |  |  |  |  |
1408 | 2 | 89µs | 2 | 52µs | # spent 29µs (6+23) within Test::More::BEGIN@1408 which was called: # once (6µs+23µs) by main::BEGIN@5 at line 1408 no warnings 'exiting'; # spent 29µs making 1 call to Test::More::BEGIN@1408 # spent 23µs making 1 call to warnings::unimport
1409 |  |  |  |  | last SKIP;
1410 |  |  |  |  | }
1411 |  |  |  |  |
1412 |  |  |  |  | =item B<TODO: BLOCK>
1413 |  |  |  |  |
1414 |  |  |  |  | TODO: {
1415 |  |  |  |  | local $TODO = $why if $condition;
1416 |  |  |  |  |
1417 |  |  |  |  | ...normal testing code goes here...
1418 |  |  |  |  | }
1419 |  |  |  |  |
1420 |  |  |  |  | Declares a block of tests you expect to fail and $why. Perhaps it's
1421 |  |  |  |  | because you haven't fixed a bug or haven't finished a new feature:
1422 |  |  |  |  |
1423 |  |  |  |  | TODO: {
1424 |  |  |  |  | local $TODO = "URI::Geller not finished";
1425 |  |  |  |  |
1426 |  |  |  |  | my $card = "Eight of clubs";
1427 |  |  |  |  | is( URI::Geller->your_card, $card, 'Is THIS your card?' );
1428 |  |  |  |  |
1429 |  |  |  |  | my $spoon;
1430 |  |  |  |  | URI::Geller->bend_spoon;
1431 |  |  |  |  | is( $spoon, 'bent', "Spoon bending, that's original" );
1432 |  |  |  |  | }
1433 |  |  |  |  |
1434 |  |  |  |  | With a todo block, the tests inside are expected to fail. Test::More
1435 |  |  |  |  | will run the tests normally, but print out special flags indicating
1436 |  |  |  |  | they are "todo". L<Test::Harness> will interpret failures as being ok.
1437 |  |  |  |  | Should anything succeed, it will report it as an unexpected success.
1438 |  |  |  |  | You then know the thing you had todo is done and can remove the
1439 |  |  |  |  | TODO flag.
1440 |  |  |  |  |
1441 |  |  |  |  | The nice part about todo tests, as opposed to simply commenting out a
1442 |  |  |  |  | block of tests, is that it is like having a programmatic todo list. You know
1443 |  |  |  |  | how much work is left to be done, you're aware of what bugs there are,
1444 |  |  |  |  | and you'll know immediately when they're fixed.
1445 |  |  |  |  |
1446 |  |  |  |  | Once a todo test starts succeeding, simply move it outside the block.
1447 |  |  |  |  | When the block is empty, delete it.
1448 |  |  |  |  |
1449 |  |  |  |  | Note that, if you leave $TODO unset or undef, Test::More reports failures
1450 |  |  |  |  | as normal. This can be useful to mark the tests as expected to fail only
1451 |  |  |  |  | in certain conditions, e.g.:
1452 |  |  |  |  |
1453 |  |  |  |  | TODO: {
1454 |  |  |  |  | local $TODO = "$^O doesn't work yet. :(" if !_os_is_supported($^O);
1455 |  |  |  |  |
1456 |  |  |  |  | ...
1457 |  |  |  |  | }
1458 |  |  |  |  |
1459 |  |  |  |  | =item B<todo_skip>
1460 |  |  |  |  |
1461 |  |  |  |  | TODO: {
1462 |  |  |  |  | todo_skip $why, $how_many if $condition;
1463 |  |  |  |  |
1464 |  |  |  |  | ...normal testing code...
1465 |  |  |  |  | }
1466 |  |  |  |  |
1467 |  |  |  |  | With todo tests, it's best to have the tests actually run. That way
1468 |  |  |  |  | you'll know when they start passing. Sometimes this isn't possible.
1469 |  |  |  |  | Often a failing test will cause the whole program to die or hang, even
1470 |  |  |  |  | inside an C<eval BLOCK> with and using C<alarm>. In these extreme
1471 |  |  |  |  | cases you have no choice but to skip over the broken tests entirely.
1472 |  |  |  |  |
1473 |  |  |  |  | The syntax and behavior is similar to a C<SKIP: BLOCK> except the
1474 |  |  |  |  | tests will be marked as failing but todo. L<Test::Harness> will
1475 |  |  |  |  | interpret them as passing.
1476 |  |  |  |  |
1477 |  |  |  |  | =cut
1478 |  |  |  |  |
1479 |  |  |  |  | sub todo_skip {
1480 |  |  |  |  | my( $why, $how_many ) = @_;
1481 |  |  |  |  | my $tb = Test::More->builder;
1482 |  |  |  |  |
1483 |  |  |  |  | unless( defined $how_many ) {
1484 |  |  |  |  | # $how_many can only be avoided when no_plan is in use.
1485 |  |  |  |  | _carp "todo_skip() needs to know \$how_many tests are in the block"
1486 |  |  |  |  | unless $tb->has_plan eq 'no_plan';
1487 |  |  |  |  | $how_many = 1;
1488 |  |  |  |  | }
1489 |  |  |  |  |
1490 |  |  |  |  | for( 1 .. $how_many ) {
1491 |  |  |  |  | $tb->todo_skip($why);
1492 |  |  |  |  | }
1493 |  |  |  |  |
1494 | 2 | 569µs | 2 | 28µs | # spent 16µs (4+12) within Test::More::BEGIN@1494 which was called: # once (4µs+12µs) by main::BEGIN@5 at line 1494 no warnings 'exiting'; # spent 16µs making 1 call to Test::More::BEGIN@1494 # spent 12µs making 1 call to warnings::unimport
1495 |  |  |  |  | last TODO;
1496 |  |  |  |  | }
1497 |  |  |  |  |
1498 |  |  |  |  | =item When do I use SKIP vs. TODO?
1499 |  |  |  |  |
1500 |  |  |  |  | B<If it's something the user might not be able to do>, use SKIP.
1501 |  |  |  |  | This includes optional modules that aren't installed, running under
1502 |  |  |  |  | an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe
1503 |  |  |  |  | you need an Internet connection and one isn't available.
1504 |  |  |  |  |
1505 |  |  |  |  | B<If it's something the programmer hasn't done yet>, use TODO. This
1506 |  |  |  |  | is for any code you haven't written yet, or bugs you have yet to fix,
1507 |  |  |  |  | but want to put tests in your testing script (always a good idea).
1508 |  |  |  |  |
1509 |  |  |  |  |
1510 |  |  |  |  | =back
1511 |  |  |  |  |
1512 |  |  |  |  |
1513 |  |  |  |  | =head2 Test control
1514 |  |  |  |  |
1515 |  |  |  |  | =over 4
1516 |  |  |  |  |
1517 |  |  |  |  | =item B<BAIL_OUT>
1518 |  |  |  |  |
1519 |  |  |  |  | BAIL_OUT($reason);
1520 |  |  |  |  |
1521 |  |  |  |  | Indicates to the harness that things are going so badly all testing
1522 |  |  |  |  | should terminate. This includes the running of any additional test scripts.
1523 |  |  |  |  |
1524 |  |  |  |  | This is typically used when testing cannot continue such as a critical
1525 |  |  |  |  | module failing to compile or a necessary external utility not being
1526 |  |  |  |  | available such as a database connection failing.
1527 |  |  |  |  |
1528 |  |  |  |  | The test will exit with 255.
1529 |  |  |  |  |
1530 |  |  |  |  | For even better control look at L<Test::Most>.
1531 |  |  |  |  |
1532 |  |  |  |  | =cut
1533 |  |  |  |  |
1534 |  |  |  |  | sub BAIL_OUT {
1535 |  |  |  |  | my $reason = shift;
1536 |  |  |  |  | my $tb = Test::More->builder;
1537 |  |  |  |  |
1538 |  |  |  |  | $tb->BAIL_OUT($reason);
1539 |  |  |  |  | }
1540 |  |  |  |  |
1541 |  |  |  |  | =back
1542 |  |  |  |  |
1543 |  |  |  |  |
1544 |  |  |  |  | =head2 Discouraged comparison functions
1545 |  |  |  |  |
1546 |  |  |  |  | The use of the following functions is discouraged as they are not
1547 |  |  |  |  | actually testing functions and produce no diagnostics to help figure
1548 |  |  |  |  | out what went wrong. They were written before C<is_deeply()> existed
1549 |  |  |  |  | because I couldn't figure out how to display a useful diff of two
1550 |  |  |  |  | arbitrary data structures.
1551 |  |  |  |  |
1552 |  |  |  |  | These functions are usually used inside an C<ok()>.
1553 |  |  |  |  |
1554 |  |  |  |  | ok( eq_array(\@got, \@expected) );
1555 |  |  |  |  |
1556 |  |  |  |  | C<is_deeply()> can do that better and with diagnostics.
1557 |  |  |  |  |
1558 |  |  |  |  | is_deeply( \@got, \@expected );
1559 |  |  |  |  |
1560 |  |  |  |  | They may be deprecated in future versions.
1561 |  |  |  |  |
1562 |  |  |  |  | =over 4
1563 |  |  |  |  |
1564 |  |  |  |  | =item B<eq_array>
1565 |  |  |  |  |
1566 |  |  |  |  | my $is_eq = eq_array(\@got, \@expected);
1567 |  |  |  |  |
1568 |  |  |  |  | Checks if two arrays are equivalent. This is a deep check, so
1569 |  |  |  |  | multi-level structures are handled correctly.
1570 |  |  |  |  |
1571 |  |  |  |  | =cut
1572 |  |  |  |  |
1573 |  |  |  |  | #'#
1574 |  |  |  |  | sub eq_array {
1575 |  |  |  |  | local @Data_Stack = ();
1576 |  |  |  |  | _deep_check(@_);
1577 |  |  |  |  | }
1578 |  |  |  |  |
1579 |  |  |  |  | sub _eq_array {
1580 |  |  |  |  | my( $a1, $a2 ) = @_;
1581 |  |  |  |  |
1582 |  |  |  |  | if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
1583 |  |  |  |  | warn "eq_array passed a non-array ref";
1584 |  |  |  |  | return 0;
1585 |  |  |  |  | }
1586 |  |  |  |  |
1587 |  |  |  |  | return 1 if $a1 eq $a2;
1588 |  |  |  |  |
1589 |  |  |  |  | my $ok = 1;
1590 |  |  |  |  | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
1591 |  |  |  |  | for( 0 .. $max ) {
1592 |  |  |  |  | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
1593 |  |  |  |  | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
1594 |  |  |  |  |
1595 |  |  |  |  | next if _equal_nonrefs($e1, $e2);
1596 |  |  |  |  |
1597 |  |  |  |  | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
1598 |  |  |  |  | $ok = _deep_check( $e1, $e2 );
1599 |  |  |  |  | pop @Data_Stack if $ok;
1600 |  |  |  |  |
1601 |  |  |  |  | last unless $ok;
1602 |  |  |  |  | }
1603 |  |  |  |  |
1604 |  |  |  |  | return $ok;
1605 |  |  |  |  | }
1606 |  |  |  |  |
1607 |  |  |  |  | sub _equal_nonrefs {
1608 |  |  |  |  | my( $e1, $e2 ) = @_;
1609 |  |  |  |  |
1610 |  |  |  |  | return if ref $e1 or ref $e2;
1611 |  |  |  |  |
1612 |  |  |  |  | if ( defined $e1 ) {
1613 |  |  |  |  | return 1 if defined $e2 and $e1 eq $e2;
1614 |  |  |  |  | }
1615 |  |  |  |  | else {
1616 |  |  |  |  | return 1 if !defined $e2;
1617 |  |  |  |  | }
1618 |  |  |  |  |
1619 |  |  |  |  | return;
1620 |  |  |  |  | }
1621 |  |  |  |  |
1622 |  |  |  |  | sub _deep_check {
1623 |  |  |  |  | my( $e1, $e2 ) = @_;
1624 |  |  |  |  | my $tb = Test::More->builder;
1625 |  |  |  |  |
1626 |  |  |  |  | my $ok = 0;
1627 |  |  |  |  |
1628 |  |  |  |  | # Effectively turn %Refs_Seen into a stack. This avoids picking up
1629 |  |  |  |  | # the same referenced used twice (such as [\$a, \$a]) to be considered
1630 |  |  |  |  | # circular.
1631 |  |  |  |  | local %Refs_Seen = %Refs_Seen;
1632 |  |  |  |  |
1633 |  |  |  |  | {
1634 |  |  |  |  | $tb->_unoverload_str( \$e1, \$e2 );
1635 |  |  |  |  |
1636 |  |  |  |  | # Either they're both references or both not.
1637 |  |  |  |  | my $same_ref = !( !ref $e1 xor !ref $e2 );
1638 |  |  |  |  | my $not_ref = ( !ref $e1 and !ref $e2 );
1639 |  |  |  |  |
1640 |  |  |  |  | if( defined $e1 xor defined $e2 ) {
1641 |  |  |  |  | $ok = 0;
1642 |  |  |  |  | }
1643 |  |  |  |  | elsif( !defined $e1 and !defined $e2 ) {
1644 |  |  |  |  | # Shortcut if they're both undefined.
1645 |  |  |  |  | $ok = 1;
1646 |  |  |  |  | }
1647 |  |  |  |  | elsif( _dne($e1) xor _dne($e2) ) {
1648 |  |  |  |  | $ok = 0;
1649 |  |  |  |  | }
1650 |  |  |  |  | elsif( $same_ref and( $e1 eq $e2 ) ) {
1651 |  |  |  |  | $ok = 1;
1652 |  |  |  |  | }
1653 |  |  |  |  | elsif($not_ref) {
1654 |  |  |  |  | push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
1655 |  |  |  |  | $ok = 0;
1656 |  |  |  |  | }
1657 |  |  |  |  | else {
1658 |  |  |  |  | if( $Refs_Seen{$e1} ) {
1659 |  |  |  |  | return $Refs_Seen{$e1} eq $e2;
1660 |  |  |  |  | }
1661 |  |  |  |  | else {
1662 |  |  |  |  | $Refs_Seen{$e1} = "$e2";
1663 |  |  |  |  | }
1664 |  |  |  |  |
1665 |  |  |  |  | my $type = _type($e1);
1666 |  |  |  |  | $type = 'DIFFERENT' unless _type($e2) eq $type;
1667 |  |  |  |  |
1668 |  |  |  |  | if( $type eq 'DIFFERENT' ) {
1669 |  |  |  |  | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1670 |  |  |  |  | $ok = 0;
1671 |  |  |  |  | }
1672 |  |  |  |  | elsif( $type eq 'ARRAY' ) {
1673 |  |  |  |  | $ok = _eq_array( $e1, $e2 );
1674 |  |  |  |  | }
1675 |  |  |  |  | elsif( $type eq 'HASH' ) {
1676 |  |  |  |  | $ok = _eq_hash( $e1, $e2 );
1677 |  |  |  |  | }
1678 |  |  |  |  | elsif( $type eq 'REF' ) {
1679 |  |  |  |  | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1680 |  |  |  |  | $ok = _deep_check( $$e1, $$e2 );
1681 |  |  |  |  | pop @Data_Stack if $ok;
1682 |  |  |  |  | }
1683 |  |  |  |  | elsif( $type eq 'SCALAR' ) {
1684 |  |  |  |  | push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
1685 |  |  |  |  | $ok = _deep_check( $$e1, $$e2 );
1686 |  |  |  |  | pop @Data_Stack if $ok;
1687 |  |  |  |  | }
1688 |  |  |  |  | elsif($type) {
1689 |  |  |  |  | push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1690 |  |  |  |  | $ok = 0;
1691 |  |  |  |  | }
1692 |  |  |  |  | else {
1693 |  |  |  |  | _whoa( 1, "No type in _deep_check" );
1694 |  |  |  |  | }
1695 |  |  |  |  | }
1696 |  |  |  |  | }
1697 |  |  |  |  |
1698 |  |  |  |  | return $ok;
1699 |  |  |  |  | }
1700 |  |  |  |  |
1701 |  |  |  |  | sub _whoa {
1702 |  |  |  |  | my( $check, $desc ) = @_;
1703 |  |  |  |  | if($check) {
1704 |  |  |  |  | die <<"WHOA";
1705 |  |  |  |  | WHOA! $desc
1706 |  |  |  |  | This should never happen! Please contact the author immediately!
1707 |  |  |  |  | WHOA
1708 |  |  |  |  | }
1709 |  |  |  |  | }
1710 |  |  |  |  |
1711 |  |  |  |  | =item B<eq_hash>
1712 |  |  |  |  |
1713 |  |  |  |  | my $is_eq = eq_hash(\%got, \%expected);
1714 |  |  |  |  |
1715 |  |  |  |  | Determines if the two hashes contain the same keys and values. This
1716 |  |  |  |  | is a deep check.
1717 |  |  |  |  |
1718 |  |  |  |  | =cut
1719 |  |  |  |  |
1720 |  |  |  |  | sub eq_hash {
1721 |  |  |  |  | local @Data_Stack = ();
1722 |  |  |  |  | return _deep_check(@_);
1723 |  |  |  |  | }
1724 |  |  |  |  |
1725 |  |  |  |  | sub _eq_hash {
1726 |  |  |  |  | my( $a1, $a2 ) = @_;
1727 |  |  |  |  |
1728 |  |  |  |  | if( grep _type($_) ne 'HASH', $a1, $a2 ) {
1729 |  |  |  |  | warn "eq_hash passed a non-hash ref";
1730 |  |  |  |  | return 0;
1731 |  |  |  |  | }
1732 |  |  |  |  |
1733 |  |  |  |  | return 1 if $a1 eq $a2;
1734 |  |  |  |  |
1735 |  |  |  |  | my $ok = 1;
1736 |  |  |  |  | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
1737 |  |  |  |  | foreach my $k ( keys %$bigger ) {
1738 |  |  |  |  | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
1739 |  |  |  |  | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
1740 |  |  |  |  |
1741 |  |  |  |  | next if _equal_nonrefs($e1, $e2);
1742 |  |  |  |  |
1743 |  |  |  |  | push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
1744 |  |  |  |  | $ok = _deep_check( $e1, $e2 );
1745 |  |  |  |  | pop @Data_Stack if $ok;
1746 |  |  |  |  |
1747 |  |  |  |  | last unless $ok;
1748 |  |  |  |  | }
1749 |  |  |  |  |
1750 |  |  |  |  | return $ok;
1751 |  |  |  |  | }
1752 |  |  |  |  |
1753 |  |  |  |  | =item B<eq_set>
1754 |  |  |  |  |
1755 |  |  |  |  | my $is_eq = eq_set(\@got, \@expected);
1756 |  |  |  |  |
1757 |  |  |  |  | Similar to C<eq_array()>, except the order of the elements is B<not>
1758 |  |  |  |  | important. This is a deep check, but the irrelevancy of order only
1759 |  |  |  |  | applies to the top level.
1760 |  |  |  |  |
1761 |  |  |  |  | ok( eq_set(\@got, \@expected) );
1762 |  |  |  |  |
1763 |  |  |  |  | Is better written:
1764 |  |  |  |  |
1765 |  |  |  |  | is_deeply( [sort @got], [sort @expected] );
1766 |  |  |  |  |
1767 |  |  |  |  | B<NOTE> By historical accident, this is not a true set comparison.
1768 |  |  |  |  | While the order of elements does not matter, duplicate elements do.
1769 |  |  |  |  |
1770 |  |  |  |  | B<NOTE> C<eq_set()> does not know how to deal with references at the top
1771 |  |  |  |  | level. The following is an example of a comparison which might not work:
1772 |  |  |  |  |
1773 |  |  |  |  | eq_set([\1, \2], [\2, \1]);
1774 |  |  |  |  |
1775 |  |  |  |  | L<Test::Deep> contains much better set comparison functions.
1776 |  |  |  |  |
1777 |  |  |  |  | =cut
1778 |  |  |  |  |
1779 |  |  |  |  | sub eq_set {
1780 |  |  |  |  | my( $a1, $a2 ) = @_;
1781 |  |  |  |  | return 0 unless @$a1 == @$a2;
1782 |  |  |  |  |
1783 | 2 | 127µs | 2 | 62µs | # spent 34µs (5+28) within Test::More::BEGIN@1783 which was called: # once (5µs+28µs) by main::BEGIN@5 at line 1783 no warnings 'uninitialized'; # spent 34µs making 1 call to Test::More::BEGIN@1783 # spent 28µs making 1 call to warnings::unimport
1784 |  |  |  |  |
1785 |  |  |  |  | # It really doesn't matter how we sort them, as long as both arrays are
1786 |  |  |  |  | # sorted with the same algorithm.
1787 |  |  |  |  | #
1788 |  |  |  |  | # Ensure that references are not accidentally treated the same as a
1789 |  |  |  |  | # string containing the reference.
1790 |  |  |  |  | #
1791 |  |  |  |  | # Have to inline the sort routine due to a threading/sort bug.
1792 |  |  |  |  | # See [rt.cpan.org 6782]
1793 |  |  |  |  | #
1794 |  |  |  |  | # I don't know how references would be sorted so we just don't sort
1795 |  |  |  |  | # them. This means eq_set doesn't really work with refs.
1796 |  |  |  |  | return eq_array(
1797 |  |  |  |  | [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
1798 |  |  |  |  | [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
1799 |  |  |  |  | );
1800 |  |  |  |  | }
1801 |  |  |  |  |
1802 |  |  |  |  | =back
1803 |  |  |  |  |
1804 |  |  |  |  |
1805 |  |  |  |  | =head2 Extending and Embedding Test::More
1806 |  |  |  |  |
1807 |  |  |  |  | Sometimes the Test::More interface isn't quite enough. Fortunately,
1808 |  |  |  |  | Test::More is built on top of L<Test::Builder> which provides a single,
1809 |  |  |  |  | unified backend for any test library to use. This means two test
1810 |  |  |  |  | libraries which both use L<Test::Builder> B<can> be used together in the
1811 |  |  |  |  | same program.
1812 |  |  |  |  |
1813 |  |  |  |  | If you simply want to do a little tweaking of how the tests behave,
1814 |  |  |  |  | you can access the underlying L<Test::Builder> object like so:
1815 |  |  |  |  |
1816 |  |  |  |  | =over 4
1817 |  |  |  |  |
1818 |  |  |  |  | =item B<builder>
1819 |  |  |  |  |
1820 |  |  |  |  | my $test_builder = Test::More->builder;
1821 |  |  |  |  |
1822 |  |  |  |  | Returns the L<Test::Builder> object underlying Test::More for you to play
1823 |  |  |  |  | with.
1824 |  |  |  |  |
1825 |  |  |  |  |
1826 |  |  |  |  | =back
1827 |  |  |  |  |
1828 |  |  |  |  |
1829 |  |  |  |  | =head1 EXIT CODES
1830 |  |  |  |  |
1831 |  |  |  |  | If all your tests passed, L<Test::Builder> will exit with zero (which is
1832 |  |  |  |  | normal). If anything failed it will exit with how many failed. If
1833 |  |  |  |  | you run less (or more) tests than you planned, the missing (or extras)
1834 |  |  |  |  | will be considered failures. If no tests were ever run L<Test::Builder>
1835 |  |  |  |  | will throw a warning and exit with 255. If the test died, even after
1836 |  |  |  |  | having successfully completed all its tests, it will still be
1837 |  |  |  |  | considered a failure and will exit with 255.
1838 |  |  |  |  |
1839 |  |  |  |  | So the exit codes are...
1840 |  |  |  |  |
1841 |  |  |  |  | 0 all tests successful
1842 |  |  |  |  | 255 test died or all passed but wrong # of tests run
1843 |  |  |  |  | any other number how many failed (including missing or extras)
1844 |  |  |  |  |
1845 |  |  |  |  | If you fail more than 254 tests, it will be reported as 254.
1846 |  |  |  |  |
1847 |  |  |  |  | B<NOTE> This behavior may go away in future versions.
1848 |  |  |  |  |
1849 |  |  |  |  |
1850 |  |  |  |  | =head1 COMPATIBILITY
1851 |  |  |  |  |
1852 |  |  |  |  | Test::More works with Perls as old as 5.8.1.
1853 |  |  |  |  |
1854 |  |  |  |  | Thread support is not very reliable before 5.10.1, but that's
1855 |  |  |  |  | because threads are not very reliable before 5.10.1.
1856 |  |  |  |  |
1857 |  |  |  |  | Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88.
1858 |  |  |  |  |
1859 |  |  |  |  | Key feature milestones include:
1860 |  |  |  |  |
1861 |  |  |  |  | =over 4
1862 |  |  |  |  |
1863 |  |  |  |  | =item subtests
1864 |  |  |  |  |
1865 |  |  |  |  | Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98.
1866 |  |  |  |  |
1867 |  |  |  |  | =item C<done_testing()>
1868 |  |  |  |  |
1869 |  |  |  |  | This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1870 |  |  |  |  |
1871 |  |  |  |  | =item C<cmp_ok()>
1872 |  |  |  |  |
1873 |  |  |  |  | Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1874 |  |  |  |  |
1875 |  |  |  |  | =item C<new_ok()> C<note()> and C<explain()>
1876 |  |  |  |  |
1877 |  |  |  |  | These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1878 |  |  |  |  |
1879 |  |  |  |  | =back
1880 |  |  |  |  |
1881 |  |  |  |  | There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>:
1882 |  |  |  |  |
1883 |  |  |  |  | $ corelist -a Test::More
1884 |  |  |  |  |
1885 |  |  |  |  |
1886 |  |  |  |  | =head1 CAVEATS and NOTES
1887 |  |  |  |  |
1888 |  |  |  |  | =over 4
1889 |  |  |  |  |
1890 |  |  |  |  | =item utf8 / "Wide character in print"
1891 |  |  |  |  |
1892 |  |  |  |  | If you use utf8 or other non-ASCII characters with Test::More you
1893 |  |  |  |  | might get a "Wide character in print" warning. Using
1894 |  |  |  |  | C<< binmode STDOUT, ":utf8" >> will not fix it.
1895 |  |  |  |  | L<Test::Builder> (which powers
1896 |  |  |  |  | Test::More) duplicates STDOUT and STDERR. So any changes to them,
1897 |  |  |  |  | including changing their output disciplines, will not be seen by
1898 |  |  |  |  | Test::More.
1899 |  |  |  |  |
1900 |  |  |  |  | One work around is to apply encodings to STDOUT and STDERR as early
1901 |  |  |  |  | as possible and before Test::More (or any other Test module) loads.
1902 |  |  |  |  |
1903 |  |  |  |  | use open ':std', ':encoding(utf8)';
1904 |  |  |  |  | use Test::More;
1905 |  |  |  |  |
1906 |  |  |  |  | A more direct work around is to change the filehandles used by
1907 |  |  |  |  | L<Test::Builder>.
1908 |  |  |  |  |
1909 |  |  |  |  | my $builder = Test::More->builder;
1910 |  |  |  |  | binmode $builder->output, ":encoding(utf8)";
1911 |  |  |  |  | binmode $builder->failure_output, ":encoding(utf8)";
1912 |  |  |  |  | binmode $builder->todo_output, ":encoding(utf8)";
1913 |  |  |  |  |
1914 |  |  |  |  |
1915 |  |  |  |  | =item Overloaded objects
1916 |  |  |  |  |
1917 |  |  |  |  | String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s
1918 |  |  |  |  | case, strings or numbers as appropriate to the comparison op). This
1919 |  |  |  |  | prevents Test::More from piercing an object's interface allowing
1920 |  |  |  |  | better blackbox testing. So if a function starts returning overloaded
1921 |  |  |  |  | objects instead of bare strings your tests won't notice the
1922 |  |  |  |  | difference. This is good.
1923 |  |  |  |  |
1924 |  |  |  |  | However, it does mean that functions like C<is_deeply()> cannot be used to
1925 |  |  |  |  | test the internals of string overloaded objects. In this case I would
1926 |  |  |  |  | suggest L<Test::Deep> which contains more flexible testing functions for
1927 |  |  |  |  | complex data structures.
1928 |  |  |  |  |
1929 |  |  |  |  |
1930 |  |  |  |  | =item Threads
1931 |  |  |  |  |
1932 |  |  |  |  | Test::More will only be aware of threads if C<use threads> has been done
1933 |  |  |  |  | I<before> Test::More is loaded. This is ok:
1934 |  |  |  |  |
1935 |  |  |  |  | use threads;
1936 |  |  |  |  | use Test::More;
1937 |  |  |  |  |
1938 |  |  |  |  | This may cause problems:
1939 |  |  |  |  |
1940 |  |  |  |  | use Test::More
1941 |  |  |  |  | use threads;
1942 |  |  |  |  |
1943 |  |  |  |  | 5.8.1 and above are supported. Anything below that has too many bugs.
1944 |  |  |  |  |
1945 |  |  |  |  | =back
1946 |  |  |  |  |
1947 |  |  |  |  |
1948 |  |  |  |  | =head1 HISTORY
1949 |  |  |  |  |
1950 |  |  |  |  | This is a case of convergent evolution with Joshua Pritikin's L<Test>
1951 |  |  |  |  | module. I was largely unaware of its existence when I'd first
1952 |  |  |  |  | written my own C<ok()> routines. This module exists because I can't
1953 |  |  |  |  | figure out how to easily wedge test names into Test's interface (along
1954 |  |  |  |  | with a few other problems).
1955 |  |  |  |  |
1956 |  |  |  |  | The goal here is to have a testing utility that's simple to learn,
1957 |  |  |  |  | quick to use and difficult to trip yourself up with while still
1958 |  |  |  |  | providing more flexibility than the existing Test.pm. As such, the
1959 |  |  |  |  | names of the most common routines are kept tiny, special cases and
1960 |  |  |  |  | magic side-effects are kept to a minimum. WYSIWYG.
1961 |  |  |  |  |
1962 |  |  |  |  |
1963 |  |  |  |  | =head1 SEE ALSO
1964 |  |  |  |  |
1965 |  |  |  |  | =head2
1966 |  |  |  |  |
1967 |  |  |  |  | =head2 ALTERNATIVES
1968 |  |  |  |  |
1969 |  |  |  |  | L<Test2::Suite> is the most recent and modern set of tools for testing.
1970 |  |  |  |  |
1971 |  |  |  |  | L<Test::Simple> if all this confuses you and you just want to write
1972 |  |  |  |  | some tests. You can upgrade to Test::More later (it's forward
1973 |  |  |  |  | compatible).
1974 |  |  |  |  |
1975 |  |  |  |  | L<Test::Legacy> tests written with Test.pm, the original testing
1976 |  |  |  |  | module, do not play well with other testing libraries. Test::Legacy
1977 |  |  |  |  | emulates the Test.pm interface and does play well with others.
1978 |  |  |  |  |
1979 |  |  |  |  | =head2 ADDITIONAL LIBRARIES
1980 |  |  |  |  |
1981 |  |  |  |  | L<Test::Differences> for more ways to test complex data structures.
1982 |  |  |  |  | And it plays well with Test::More.
1983 |  |  |  |  |
1984 |  |  |  |  | L<Test::Class> is like xUnit but more perlish.
1985 |  |  |  |  |
1986 |  |  |  |  | L<Test::Deep> gives you more powerful complex data structure testing.
1987 |  |  |  |  |
1988 |  |  |  |  | L<Test::Inline> shows the idea of embedded testing.
1989 |  |  |  |  |
1990 |  |  |  |  | L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on
1991 |  |  |  |  | the fly. Can also override, block, or reimplement packages as needed.
1992 |  |  |  |  |
1993 |  |  |  |  | L<Test::FixtureBuilder> Quickly define fixture data for unit tests.
1994 |  |  |  |  |
1995 |  |  |  |  | =head2 OTHER COMPONENTS
1996 |  |  |  |  |
1997 |  |  |  |  | L<Test::Harness> is the test runner and output interpreter for Perl.
1998 |  |  |  |  | It's the thing that powers C<make test> and where the C<prove> utility
1999 |  |  |  |  | comes from.
2000 |  |  |  |  |
2001 |  |  |  |  | =head2 BUNDLES
2002 |  |  |  |  |
2003 |  |  |  |  | L<Test::Most> Most commonly needed test functions and features.
2004 |  |  |  |  |
2005 |  |  |  |  | =head1 AUTHORS
2006 |  |  |  |  |
2007 |  |  |  |  | Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
2008 |  |  |  |  | from Joshua Pritikin's Test module and lots of help from Barrie
2009 |  |  |  |  | Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
2010 |  |  |  |  | the perl-qa gang.
2011 |  |  |  |  |
2012 |  |  |  |  | =head1 MAINTAINERS
2013 |  |  |  |  |
2014 |  |  |  |  | =over 4
2015 |  |  |  |  |
2016 |  |  |  |  | =item Chad Granum E<lt>exodist@cpan.orgE<gt>
2017 |  |  |  |  |
2018 |  |  |  |  | =back
2019 |  |  |  |  |
2020 |  |  |  |  |
2021 |  |  |  |  | =head1 BUGS
2022 |  |  |  |  |
2023 |  |  |  |  | See F<https://github.com/Test-More/test-more/issues> to report and view bugs.
2024 |  |  |  |  |
2025 |  |  |  |  |
2026 |  |  |  |  | =head1 SOURCE
2027 |  |  |  |  |
2028 |  |  |  |  | The source code repository for Test::More can be found at
2029 |  |  |  |  | F<http://github.com/Test-More/test-more/>.
2030 |  |  |  |  |
2031 |  |  |  |  |
2032 |  |  |  |  | =head1 COPYRIGHT
2033 |  |  |  |  |
2034 |  |  |  |  | Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2035 |  |  |  |  |
2036 |  |  |  |  | This program is free software; you can redistribute it and/or
2037 |  |  |  |  | modify it under the same terms as Perl itself.
2038 |  |  |  |  |
2039 |  |  |  |  | See F<http://www.perl.com/perl/misc/Artistic.html>
2040 |  |  |  |  |
2041 |  |  |  |  | =cut
2042 |  |  |  |  |
2043 | 1 | 5µs |  |  | 1;