File Coverage

blib/lib/Test/Workflow/Block.pm
Criterion Covered Total %
statement 57 65 87.6
branch 24 30 80.0
condition 24 41 58.5
subroutine 9 9 100.0
pod 0 3 0.0
total 114 148 77.0


line stmt bran cond sub pod time code
1             package Test::Workflow::Block;
2 137     137   758 use strict;
  137         292  
  137         4968  
3 137     137   776 use warnings;
  137         331  
  137         4846  
4              
5 137     137   1922 use Fennec::Util qw/accessors/;
  137         266  
  137         1997  
6 137     137   79437 use Carp qw/croak/;
  137         379  
  137         17461  
7 137     137   860 use B ();
  137         315  
  137         14722  
8 137     137   1005 use Scalar::Util qw/blessed/;
  137         293  
  137         220457  
9             require Time::HiRes;
10              
11             our @CARP_NOT = qw{
12             Test::Workflow
13             Test::Workflow::Meta
14             Test::Workflow::Block
15             Test::Workflow::Layer
16             };
17              
18             accessors qw{
19             name start_line end_line code verbose package diag skip todo should_fail subtype
20             };
21              
22             sub new {
23 1286     1286 0 2198 my $class = shift;
24 1286         3345 my ( $caller, $name, @args ) = @_;
25 1286         1475 my $code;
26              
27 1286 50 33     20038 croak "You must provide a caller (got: $caller)"
      33        
      33        
28             unless $caller && ref $caller && ref $caller eq 'ARRAY' && @$caller;
29 1286 50 33     6250 croak "You must provide a name"
30             unless $name and !ref $name;
31              
32             # If code is first, grab it
33 1286 100 66     5983 $code = shift(@args)
34             if ref $args[0]
35             && ref $args[0] eq 'CODE';
36              
37             # If code is last, grab it
38 1286   100     4429 my $ref = ref $args[-1] || '';
39 1286 100 100     6135 if ( !$code && $ref eq 'CODE' ) {
40 704         1202 $code = pop(@args);
41              
42             # if code was last, and in key => code form, pop the key
43 704 100       4122 pop(@args) if $args[-1] =~ m/^(code|method|sub)$/;
44             }
45              
46             # Code must be a param
47 1286         3570 my %proto = @args;
48 1286   66     3529 $code ||= $proto{code} || $proto{method} || $proto{sub};
      66        
49              
50 1286 50 33     6457 croak "You must provide a codeblock"
51             unless $code
52             && ref $code eq 'CODE';
53              
54 1286         12511 my $start_line = B::svref_2object($code)->START->line;
55 1286         3210 my $end_line = $caller->[2];
56 1286 100       3102 $start_line-- unless $start_line == $end_line;
57              
58 1286 100       14973 %proto = (
59             %proto,
60             code => $code,
61             name => $name,
62             package => $caller->[0],
63             start_line => $start_line,
64             end_line => $end_line,
65             diag => ( $start_line == $end_line )
66             ? "line $start_line"
67             : "lines $start_line -> $end_line",
68             );
69              
70 1286         12947 return bless( \%proto, $class );
71             }
72              
73             sub clone_with {
74 79     79 0 121 my $self = shift;
75 79         196 my %params = @_;
76 79         1577 bless( {%$self, %params}, blessed($self) );
77             }
78              
79             sub run {
80 606     606 0 2049 my $self = shift;
81 606         1526 my ( $instance, $layer ) = @_;
82 606         5867 my $meta = $instance->TEST_WORKFLOW;
83 606         11895 my $name = "Group: " . $self->name;
84 606   66     9680 my $debug = $instance->can('FENNEC') && $instance->FENNEC->debug;
85              
86 606 100       4972 return $meta->skip->( $name, $self->skip )
87             if $self->skip;
88              
89 602         2080 my $ref = ref $self;
90 602         14597 $ref =~ s/^.*:://;
91 602 50       2008 if ($debug) {
92 0         0 my $collector = Fennec::Runner->new->collector;
93 0         0 my ($sec, $ms) = Time::HiRes::gettimeofday();
94 0         0 my $msg = sprintf(
95             "FENNEC_DEBUG_BLOCK:PID:%d\0START_LINE:%d\0END_LINE:%d\0TYPE:%s\0NAME:%s\0SEC:%d\0MSEC:%d\0STATE:START\n",
96             $$,
97             $self->start_line,
98             $self->end_line,
99             $self->subtype,
100             $self->name,
101             $sec,
102             $ms,
103             );
104 0         0 $collector->diag($msg);
105             }
106              
107 602 100       3153 $meta->todo_start->( $self->todo )
108             if $self->todo;
109              
110 602   50     9118 my $success = eval { $self->code->(@_); 1 } || $self->should_fail || 0;
111 592   100     4974 my $error = $@ || "Error masked!";
112 592         1458 chomp($error);
113              
114 592 100       9044 $meta->todo_end->()
115             if $self->todo;
116              
117 592 50       2202 if ($debug) {
118 0         0 my $collector = Fennec::Runner->new->collector;
119 0         0 my ($sec, $ms) = Time::HiRes::gettimeofday();
120 0         0 my $msg = sprintf(
121             "FENNEC_DEBUG_BLOCK:PID:%d\0START_LINE:%d\0END_LINE:%d\0TYPE:%s\0NAME:%s\0SEC:%d\0MSEC:%d\0STATE:END\n",
122             $$,
123             $self->start_line,
124             $self->end_line,
125             $self->subtype,
126             $self->name,
127             $sec,
128             $ms,
129             );
130 0         0 $collector->diag($msg);
131             }
132              
133 592 100 66     6558 return if $success && !$self->verbose;
134              
135 172   50     13290 $meta->ok->( $success || 0, $name );
136 172 50       11658 $meta->diag->( " ================================" . "\n Error: " . $error . "\n Package: " . $self->package . "\n Block: '" . $self->name . "' on " . $self->diag . "\n\n" ) unless $success;
137             }
138              
139             1;
140              
141             __END__