File Coverage

blib/lib/Devel/MAT/Context.pm
Criterion Covered Total %
statement 61 85 71.7
branch 2 8 25.0
condition 1 3 33.3
subroutine 21 28 75.0
pod 4 7 57.1
total 89 131 67.9


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk
5              
6             package Devel::MAT::Context 0.50;
7              
8 9     9   819 use v5.14;
  9         30  
9 9     9   48 use warnings;
  9         18  
  9         266  
10              
11 9     9   45 use Carp;
  9         17  
  9         489  
12 9     9   51 use Scalar::Util qw( weaken );
  9         17  
  9         1044  
13              
14             =head1 NAME
15              
16             C - represent a single call context state
17              
18             =head1 DESCRIPTION
19              
20             Objects in this class represent a single level of state from the call context.
21             These contexts represent function calls between perl functions.
22              
23             =cut
24              
25             my %types;
26             sub register_type
27             {
28 27     27 0 72 $types{$_[1]} = $_[0];
29             # generate the ->type constant method
30 27         101 ( my $typename = $_[0] ) =~ s/^Devel::MAT::Context:://;
31 9     9   69 no strict 'refs';
  9         21  
  9         4536  
32 27     0   149 *{"$_[0]::type"} = sub () { $typename };
  27         182  
  0         0  
33             }
34              
35             sub new
36             {
37 5     5 0 10 shift;
38 5         10 my ( $type, $df, $bytes, undef, $strs ) = @_;
39              
40 5 50       24 $types{$type} or croak "Cannot load unknown CTX type $type";
41              
42 5         23 my $self = bless {}, $types{$type};
43 5         48 weaken( $self->{df} = $df );
44              
45 5         16 ( $self->{gimme}, $self->{line} ) = unpack "C $df->{uint_fmt}", $bytes;
46 5         13 ( $self->{file} ) = @$strs;
47              
48 5         12 return $self;
49             }
50              
51             sub load_v0_1
52             {
53 0     0 0 0 my $class = shift;
54 0         0 my ( $type, $df ) = @_;
55              
56 0 0       0 $types{$type} or croak "Cannot load unknown CTX type $type";
57              
58 0         0 my $self = bless {}, $types{$type};
59 0         0 weaken( $self->{df} = $df );
60              
61             # Standard fields all Contexts have
62 0         0 $self->{gimme} = $df->_read_u8;
63 0         0 $self->{file} = $df->_read_str;
64 0         0 $self->{line} = $df->_read_uint;
65              
66 0         0 $self->_load_v0_1( $df );
67              
68 0         0 return $self;
69             }
70              
71             =head1 COMMON METHODS
72              
73             =cut
74              
75             =head2 gimme
76              
77             $gimme = $ctx->gimme
78              
79             Returns the gimme value of the call context.
80              
81             =cut
82              
83             my @GIMMES = ( undef, qw( void scalar array ) );
84             sub gimme
85             {
86 0     0 1 0 my $self = shift;
87 0         0 return $GIMMES[ $self->{gimme} ];
88             }
89              
90             =head2 file
91              
92             =head2 line
93              
94             =head2 location
95              
96             $file = $ctx->file
97              
98             $line = $ctx->line
99              
100             $location = $ctx->location
101              
102             Returns the file, line or location as (C).
103              
104             =cut
105              
106 5     5 1 8200 sub file { my $self = shift; return $self->{file} }
  5         34  
107 5     5 1 15 sub line { my $self = shift; return $self->{line} }
  5         23  
108              
109             sub location
110             {
111 0     0 1 0 my $self = shift;
112 0         0 return "$self->{file} line $self->{line}";
113             }
114              
115             package Devel::MAT::Context::SUB 0.50;
116 9     9   66 use base qw( Devel::MAT::Context );
  9         25  
  9         4607  
117             __PACKAGE__->register_type( 1 );
118              
119             =head1 Devel::MAT::Context::SUB
120              
121             Represents a context which is a subroutine call.
122              
123             =cut
124              
125             sub load
126             {
127 3     3   6 my $self = shift;
128 3         7 my ( $bytes, $ptrs, undef ) = @_;
129              
130 3         8 my $df = $self->{df};
131              
132 3         9 ( $self->{olddepth} ) = unpack "$df->{u32_fmt}", $bytes;
133              
134 3         10 ( $self->{cv_at}, $self->{args_at} ) = @$ptrs;
135              
136 3 50       9 undef $self->{args_at} if $df->perlversion ge "5.23.8";
137             }
138              
139             sub _load_v0_1
140             {
141 0     0   0 my $self = shift;
142 0         0 my ( $df ) = @_;
143              
144 0         0 $self->{olddepth} = -1;
145              
146 0         0 $self->{cv_at} = $df->_read_ptr;
147 0         0 $self->{args_at} = $df->_read_ptr;
148              
149 0 0       0 undef $self->{args_at} if $df->perlversion ge "5.23.8";
150             }
151              
152             =head2 cv
153              
154             $cv = $ctx->cv
155              
156             Returns the CV which this call is to.
157              
158             =head2 args
159              
160             $args = $ctx->args
161              
162             Returns the arguments AV which represents the C<@_> argument array.
163              
164             =head2 olddepth
165              
166             $olddepth = $ctx->olddepth
167              
168             Returns the old depth of the context (that is, the depth the CV would be at
169             after this context returns).
170              
171             =head2 depth
172              
173             $depth = $ctx->depth
174              
175             Returns the actual depth of the context. This is inferred at load time by
176             considering the C of the next inner-nested call to the same CV, or
177             from the actual C of the CV is no other call exists.
178              
179             =cut
180              
181 8     8   16 sub cv { my $self = shift; return $self->{df}->sv_at( $self->{cv_at} ) }
  8         40  
182              
183             sub args
184             {
185 2     2   6 my $self = shift;
186             # Perl 5.23.8 removed blk_sub.argarray so we have to go the long way round
187 2   33     10 $self->{args_at} //= do {
188 2         6 my $cv = $self->cv;
189 2         7 my $args = $cv->pad( $self->depth )->elem( 0 );
190 2         17 $args->addr;
191             };
192              
193 2         8 return $self->{df}->sv_at( $self->{args_at} );
194             }
195              
196 4     4   27 sub olddepth { return $_[0]->{olddepth} }
197              
198 3     3   13 sub _set_depth { $_[0]->{depth} = $_[1] }
199 3     3   20 sub depth { return $_[0]->{depth} }
200              
201             package Devel::MAT::Context::TRY 0.50;
202 9     9   66 use base qw( Devel::MAT::Context );
  9         18  
  9         1278  
203             __PACKAGE__->register_type( 2 );
204              
205             =head1 Devel::MAT::Context::TRY
206              
207             Represents a context which is a block C call.
208              
209             =cut
210              
211       1     sub load {}
212              
213       0     sub _load_v0_1 {}
214              
215             package Devel::MAT::Context::EVAL 0.50;
216 9     9   63 use base qw( Devel::MAT::Context );
  9         16  
  9         2109  
217             __PACKAGE__->register_type( 3 );
218              
219             =head1 Devel::MAT::Context::EVAL
220              
221             Represents a context which is a string C call.
222              
223             =cut
224              
225             sub load
226             {
227 1     1   6 my $self = shift;
228 1         3 my ( undef, $ptrs, undef ) = @_;
229              
230 1         6 ( $self->{code_at} ) = @$ptrs;
231             }
232              
233             sub _load_v0_1
234             {
235 0     0   0 my $self = shift;
236 0         0 my ( $df ) = @_;
237              
238 0         0 $self->{code_at} = $df->_read_ptr;
239             }
240              
241             =head2 code
242              
243             $sv = $ctx->code
244              
245             Returns the SV containing the text string being evaluated.
246              
247             =cut
248              
249 1     1   3 sub code { my $self = shift; return $self->{df}->sv_at( $self->{code_at} ) }
  1         6  
250              
251             =head1 AUTHOR
252              
253             Paul Evans
254              
255             =cut
256              
257             0x55AA;