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