File Coverage

blib/lib/Devel/Chitin/SubroutineLocation.pm
Criterion Covered Total %
statement 15 27 55.5
branch 0 4 0.0
condition 0 9 0.0
subroutine 5 8 62.5
pod 0 2 0.0
total 20 50 40.0


line stmt bran cond sub pod time code
1             package Devel::Chitin::SubroutineLocation;
2              
3 34     34   230 use strict;
  34         1623  
  34         2759  
4 34     34   2198 use warnings;
  34         63  
  34         3476  
5              
6             our $VERSION = '0.15';
7              
8 34     34   3438 use Carp;
  34         69  
  34         6495  
9              
10             my @properties = qw(package subroutine line filename end code source source_line);
11             foreach my $prop ( @properties ) {
12 0     0     my $sub = sub { shift->{$prop} };
13 34     34   3575 no strict 'refs';
  34         69  
  34         11981  
14             *$prop = $sub;
15             }
16              
17             sub new {
18 0     0 0   my($class, %props) = @_;
19              
20 0           foreach my $prop ( @properties ) {
21 0 0         Carp::croak("$prop is a required property") unless (exists $props{$prop});
22             }
23              
24 0           return bless \%props, $class;
25             }
26              
27             sub new_from_db_sub {
28 0     0 0   my($class, $subname) = @_;
29              
30 0 0 0       return () unless (defined($subname) and $DB::sub{$subname});
31 0           my($filename, $line, $end) = $DB::sub{$subname} =~ m/(.*):(\d+)-(\d+)$/;
32 0           my($source, $source_line) = $filename =~ m/\[(.*):(\d+)\]$/;
33 0           my $glob = do {
34 34     34   2039 no strict 'refs';
  34         69  
  34         8710  
35 0           \*$subname;
36             };
37             return Devel::Chitin::SubroutineLocation->new(
38             filename => $filename,
39             line => $line,
40             end => $end,
41             source => $source || $filename,
42             source_line => $source_line || $line,
43             subroutine => *$glob{NAME},
44             package => *$glob{PACKAGE},
45 0   0       code => *$glob{CODE} );
      0        
46             }
47              
48             1;
49              
50             __END__