1package Test2::Workflow::BlockBase; 2use strict; 3use warnings; 4 5our $VERSION = '0.000162'; 6 7use Test2::Util::HashBase qw/code frame _info _lines/; 8use Test2::Util::Sub qw/sub_info/; 9use List::Util qw/min max/; 10use Carp qw/croak/; 11 12use Test2::Util::Trace(); 13 14BEGIN { 15 local ($@, $!, $SIG{__DIE__}); 16 17 my $set_name = eval { require Sub::Util; Sub::Util->can('set_subname') } 18 || eval { require Sub::Name; Sub::Name->can('subname') }; 19 20 *set_subname = $set_name ? sub { 21 my $self = shift; 22 my ($name) = @_; 23 24 $set_name->($name, $self->{+CODE}); 25 delete $self->{+_INFO}; 26 27 return 1; 28 } : sub { return 0 }; 29} 30 31sub init { 32 my $self = shift; 33 34 croak "The 'code' attribute is required" 35 unless $self->{+CODE}; 36 37 croak "The 'frame' attribute is required" 38 unless $self->{+FRAME}; 39 40 $self->{+_LINES} = delete $self->{lines} 41 if $self->{lines}; 42} 43 44sub file { shift->info->{file} } 45sub lines { shift->info->{lines} } 46sub package { shift->info->{package} } 47sub subname { shift->info->{name} } 48 49sub info { 50 my $self = shift; 51 52 unless ($self->{+_INFO}) { 53 my $info = sub_info($self->code); 54 55 my $frame = $self->frame; 56 my $file = $info->{file}; 57 my $all_lines = $info->{all_lines}; 58 my $pre_lines = $self->{+_LINES}; 59 my $lines = $info->{lines} ||= []; 60 61 if ($pre_lines && @$pre_lines) { 62 @$lines = @$pre_lines; 63 } 64 else { 65 @$lines = ( 66 min(@$all_lines, $frame->[2]), 67 max(@$all_lines, $frame->[2]), 68 ) if $frame->[1] eq $file; 69 } 70 71 # Adjust for start 72 $lines->[0]-- if $lines->[0] != $lines->[1]; 73 74 $self->{+_INFO} = $info; 75 } 76 77 return $self->{+_INFO}; 78} 79 80sub trace { 81 my $self = shift; 82 83 my ($hub, %params) = @_; 84 85 croak "'hub' is required" 86 unless $hub; 87 88 return Test2::Util::Trace->new( 89 frame => $self->frame, 90 detail => $self->debug, 91 92 buffered => $hub->buffered, 93 nested => $hub->nested, 94 hid => $hub->hid, 95 huuid => $hub->uuid, 96 97 %params, 98 ); 99} 100 101sub debug { 102 my $self = shift; 103 my $file = $self->file; 104 my $lines = $self->lines; 105 106 my $line_str = @$lines == 1 ? "around line $lines->[0]" : "around lines $lines->[0] -> $lines->[1]"; 107 return "at $file $line_str."; 108} 109 110sub throw { 111 my $self = shift; 112 my ($msg) = @_; 113 die "$msg " . $self->debug . "\n"; 114} 115 1161; 117 118__END__ 119 120=pod 121 122=encoding UTF-8 123 124=head1 NAME 125 126Test2::Workflow::BlockBase - Base class for all workflow blocks. 127 128=head1 SOURCE 129 130The source code repository for Test2-Workflow can be found at 131F<https://github.com/Test-More/Test2-Suite/>. 132 133=head1 MAINTAINERS 134 135=over 4 136 137=item Chad Granum E<lt>exodist@cpan.orgE<gt> 138 139=back 140 141=head1 AUTHORS 142 143=over 4 144 145=item Chad Granum E<lt>exodist@cpan.orgE<gt> 146 147=back 148 149=head1 COPYRIGHT 150 151Copyright 2018 Chad Granum E<lt>exodist7@gmail.comE<gt>. 152 153This program is free software; you can redistribute it and/or 154modify it under the same terms as Perl itself. 155 156See F<http://dev.perl.org/licenses/> 157 158=cut 159 160