1package Test2::Util::Sub;
2use strict;
3use warnings;
4
5our $VERSION = '0.000162';
6
7use Carp qw/croak carp/;
8use B();
9
10our @EXPORT_OK = qw{
11    sub_info
12    sub_name
13
14    gen_reader gen_writer gen_accessor
15};
16use base 'Exporter';
17
18sub gen_reader {
19    my $field = shift;
20    return sub { $_[0]->{$field} };
21}
22
23sub gen_writer {
24    my $field = shift;
25    return sub { $_[0]->{$field} = $_[1] };
26}
27
28sub gen_accessor {
29    my $field = shift;
30    return sub {
31        my $self = shift;
32        ($self->{$field}) = @_ if @_;
33        return $self->{$field};
34    };
35}
36
37sub sub_name {
38    my ($sub) = @_;
39
40    croak "sub_name requires a coderef as its only argument"
41        unless ref($sub) eq 'CODE';
42
43    my $cobj = B::svref_2object($sub);
44    my $name = $cobj->GV->NAME;
45    return $name;
46}
47
48sub sub_info {
49    my ($sub, @all_lines) = @_;
50    my %in = map {$_ => 1} @all_lines;
51
52    croak "sub_info requires a coderef as its first argument"
53        unless ref($sub) eq 'CODE';
54
55    my $cobj    = B::svref_2object($sub);
56    my $name    = $cobj->GV->NAME;
57    my $file    = $cobj->FILE;
58    my $package = $cobj->GV->STASH->NAME;
59
60    my $op = $cobj->START;
61    while ($op) {
62        push @all_lines => $op->line if $op->can('line');
63        last unless $op->can('next');
64        $op = $op->next;
65    }
66
67    my ($start, $end, @lines);
68    if (@all_lines) {
69        @all_lines = sort { $a <=> $b } @all_lines;
70        ($start, $end) = ($all_lines[0], $all_lines[-1]);
71
72        # Adjust start and end for the most common case of a multi-line block with
73        # parens on the lines before and after.
74        if ($start < $end) {
75            $start-- unless $start <= 1 || $in{$start};
76            $end++   unless $in{$end};
77        }
78        @lines = ($start, $end);
79    }
80
81    return {
82        ref        => $sub,
83        cobj       => $cobj,
84        name       => $name,
85        file       => $file,
86        package    => $package,
87        start_line => $start,
88        end_line   => $end,
89        all_lines  => \@all_lines,
90        lines      => \@lines,
91    };
92}
93
941;
95
96__END__
97
98=pod
99
100=encoding UTF-8
101
102=head1 NAME
103
104Test2::Util::Sub - Tools for inspecting and manipulating subs.
105
106=head1 DESCRIPTION
107
108Utilities used by Test2::Tools to inspect and manipulate subroutines.
109
110=head1 EXPORTS
111
112All exports are optional, you must specify subs to import.
113
114=over 4
115
116=item $name = sub_name(\&sub)
117
118Get the name of the sub.
119
120=item my $hr = sub_info(\&code)
121
122This returns a hashref with information about the sub:
123
124    {
125        ref        => \&code,
126        cobj       => $cobj,
127        name       => "Some::Mod::code",
128        file       => "Some/Mod.pm",
129        package    => "Some::Mod",
130
131        # Note: These have been adjusted based on guesswork.
132        start_line => 22,
133        end_line   => 42,
134        lines      => [22, 42],
135
136        # Not a bug, these lines are different!
137        all_lines  => [23, 25, ..., 39, 41],
138    };
139
140=over 4
141
142=item $info->{ref} => \&code
143
144This is the original sub passed to C<sub_info()>.
145
146=item $info->{cobj} => $cobj
147
148This is the c-object representation of the coderef.
149
150=item $info->{name} => "Some::Mod::code"
151
152This is the name of the coderef. For anonymous coderefs this may end with
153C<'__ANON__'>. Also note that the package 'main' is special, and 'main::' may
154be omitted.
155
156=item $info->{file} => "Some/Mod.pm"
157
158The file in which the sub was defined.
159
160=item $info->{package} => "Some::Mod"
161
162The package in which the sub was defined.
163
164=item $info->{start_line} => 22
165
166=item $info->{end_line} => 42
167
168=item $info->{lines} => [22, 42]
169
170These three fields are the I<adjusted> start line, end line, and array with both.
171It is important to note that these lines have been adjusted and may not be
172accurate.
173
174The lines are obtained by walking the ops. As such, the first line is the line
175of the first statement, and the last line is the line of the last statement.
176This means that in multi-line subs the lines are usually off by 1.  The lines
177in these keys will be adjusted for you if it detects a multi-line sub.
178
179=item $info->{all_lines} => [23, 25, ..., 39, 41]
180
181This is an array with the lines of every statement in the sub. Unlike the other
182line fields, these have not been adjusted for you.
183
184=back
185
186=back
187
188=head1 SOURCE
189
190The source code repository for Test2-Suite can be found at
191F<https://github.com/Test-More/Test2-Suite/>.
192
193=head1 MAINTAINERS
194
195=over 4
196
197=item Chad Granum E<lt>exodist@cpan.orgE<gt>
198
199=back
200
201=head1 AUTHORS
202
203=over 4
204
205=item Chad Granum E<lt>exodist@cpan.orgE<gt>
206
207=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
208
209=back
210
211=head1 COPYRIGHT
212
213Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
214
215This program is free software; you can redistribute it and/or
216modify it under the same terms as Perl itself.
217
218See F<http://dev.perl.org/licenses/>
219
220=cut
221