File Coverage

blib/lib/Test/Spec/Example.pm
Criterion Covered Total %
statement 50 79 63.2
branch 4 18 22.2
condition 4 11 36.3
subroutine 15 16 93.7
pod 0 8 0.0
total 73 132 55.3


line stmt bran cond sub pod time code
1             package Test::Spec::Example;
2              
3             # Purpose: represents an `it` block
4              
5 15     15   126 use strict;
  15         42  
  15         469  
6 15     15   95 use warnings;
  15         38  
  15         460  
7              
8             ########################################################################
9             # NO USER-SERVICEABLE PARTS INSIDE.
10             ########################################################################
11              
12 15     15   91 use Carp ();
  15         36  
  15         311  
13 15     15   94 use Scalar::Util ();
  15         51  
  15         5838  
14              
15             sub new {
16 128     128 0 1430 my ($class, $args) = @_;
17              
18 128 50 33     522 if (!$args || ref($args) ne 'HASH') {
19 0         0 Carp::croak "usage: $class->new(\\%args)";
20             }
21              
22 128         260 my $self = bless {}, $class;
23 128         263 foreach my $attr ( qw/name description code builder context/ ) {
24 640   33     1475 $self->{$attr} = $args->{$attr} || Carp::croak "$attr missing";
25             }
26              
27 128         445 Scalar::Util::weaken($self->{context});
28              
29 128         351 return $self;
30             }
31              
32 128     128 0 559 sub name { shift->{name} }
33 123     123 0 646 sub description { shift->{description} }
34 128     128 0 698 sub code { shift->{code} }
35 0     0 0 0 sub builder { shift->{builder} }
36 128     128 0 408 sub context { shift->{context} }
37              
38             # Build a stack from the starting context
39             # down to the current context
40             sub stack {
41 128     128 0 323 my ($self) = @_;
42              
43 128         798 my $ctx = $self->context;
44              
45 128         354 my @ancestors = $ctx;
46 128         446 while ( $ctx = $ctx->parent ) {
47 226         675 push @ancestors, $ctx;
48             }
49              
50 128         711 return reverse(@ancestors);
51             }
52              
53             sub run {
54 128     128 0 337 my ($self) = @_;
55              
56             # clobber Test::Builder's ok() method just like Test::Class does,
57             # but without screwing up underscores.
58 15     15   146 no warnings 'redefine';
  15         43  
  15         9055  
59 128         329 my $orig_builder_ok = \&Test::Builder::ok;
60             local *Test::Builder::ok = sub {
61 127     127   200835 my ($builder,$test,$desc) = splice(@_,0,3);
62 127   66     777 $desc ||= $self->description;
63 127         301 local $Test::Builder::Level = $Test::Builder::Level+1;
64 127         567 $orig_builder_ok->($builder, $test, $desc, @_);
65 128         924 };
66              
67             # Run the test
68 128         302 eval { $self->_runner($self->stack) };
  128         410  
69              
70             # And trap any errors
71 128 50       1904 if (my $err = $@) {
72 0         0 my $builder = $self->builder;
73 0         0 my $description = $self->description;
74              
75             # eval in case stringification overload croaks
76 0   0     0 chomp($err = eval { $err . '' } || 'unknown error');
77 0         0 my ($file,$line);
78 0 0       0 ($file,$line) = ($1,$2) if ($err =~ s/ at (.+?) line (\d+)\.\Z//);
79              
80             # disable ok()'s diagnostics so we can generate a custom TAP message
81 0         0 my $old_diag = $builder->no_diag;
82 0         0 $builder->no_diag(1);
83             # make sure we can restore no_diag
84 0         0 eval { $builder->ok(0, $description) };
  0         0  
85 0         0 my $secondary_err = $@;
86             # no_diag needs a defined value, so double-negate it to get either '' or 1
87 0         0 $builder->no_diag(!!$old_diag);
88              
89 0 0       0 unless ($builder->no_diag) {
90             # emulate Test::Builder::ok's diagnostics, but with more details
91 0         0 my ($msg,$diag_fh);
92 0 0       0 if ($builder->in_todo) {
93 0         0 $msg = "Failed (TODO)";
94 0         0 $diag_fh = $builder->todo_output;
95             }
96             else {
97 0         0 $msg = "Failed";
98 0         0 $diag_fh = $builder->failure_output;
99             }
100 0 0       0 print {$diag_fh} "\n" if $ENV{HARNESS_ACTIVE};
  0         0  
101 0         0 print {$builder->failure_output} qq[# $msg test '$description' by dying:\n];
  0         0  
102 0         0 print {$builder->failure_output} qq[# $err\n];
  0         0  
103 0 0       0 print {$builder->failure_output} qq[# at $file line $line.\n] if defined($file);
  0         0  
104             }
105 0 0       0 die $secondary_err if $secondary_err;
106             }
107             }
108              
109             sub _runner {
110 354     354   1042 my ($self, $ctx, @remainder) = @_;
111              
112             # This recursive closure essentially does this
113             # $outer->contextualize {
114             # $outer->before_each
115             # $inner->contextualize {
116             # $inner->before_each
117             # $anon->contextualize {
118             # $anon->before_each (no-op)
119             # execute test
120             # $anon->after_each (no-op)
121             # }
122             # $inner->after_each
123             # }
124             # $outer->after_each
125             # }
126             #
127             return $ctx->contextualize(sub {
128 354     354   1266 $ctx->_run_before_all_once;
129 354         1225080 $ctx->_run_before('each');
130 354 100       1332 if ( @remainder ) {
131 226         658 $self->_runner(@remainder);
132             }
133             else {
134 128         499 $ctx->_in_anonymous_context($self->code, $self);
135             }
136 354         1999 $ctx->_run_after('each');
137             # "after 'all'" only happens during context destruction (DEMOLISH).
138             # This is the only way I can think to make this work right
139             # in the case that only specific test methods are run.
140             # Otherwise, the global teardown would only happen when you
141             # happen to run the last test of the context.
142 354         2016 }, $self);
143             }
144              
145             1;