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