File Coverage

blib/lib/Devel/Chitin/Actionable.pm
Criterion Covered Total %
statement 18 102 17.6
branch 0 34 0.0
condition 0 22 0.0
subroutine 6 18 33.3
pod 7 9 77.7
total 31 185 16.7


line stmt bran cond sub pod time code
1             package Devel::Chitin::Actionable;
2              
3 34     34   188 use strict;
  34         55  
  34         884  
4 34     34   144 use warnings;
  34         51  
  34         1315  
5              
6             our $VERSION = '0.12'; # TRIAL
7              
8 34     34   155 use Digest::MD5 qw(md5);
  34         50  
  34         1504  
9 34     34   158 use Carp;
  34         51  
  34         28179  
10              
11             sub new {
12 0     0 0   my $class = shift;
13              
14 0           my %params = __required([qw(file line code)], @_);
15              
16 0           my $self = \%params;
17 0           bless $self, $class;
18 0           $self->_insert();
19 0           return $self;
20             }
21              
22             sub __required {
23 0     0     my $required_params = shift;
24 0           my %params = @_;
25 0 0         do { defined($params{$_}) || Carp::croak("$_ is a required param") }
26 0           foreach @$required_params;
27 0           return %params;
28             }
29              
30             sub get {
31 0     0 1   my $class = shift;
32 0 0         return $class if (ref $class);
33              
34 0           my %params = __required([qw(file)], @_);
35              
36 0           our %dbline;
37 0           local(*dbline) = $main::{'_<' . $params{file}};
38 0 0         return unless %dbline;
39              
40 0           my @candidates;
41              
42 0           my $type = $class->type;
43 0 0         if (!$params{line}) {
44             @candidates =
45 0 0         map { $_->{$type} ? @{$_->{$type}} : () } # only lines with the type we're looking for
  0            
46 0           grep { $_ } # only lines with something
  0            
47             values %dbline; # All action/breakpoint data for this file
48             } else {
49 0           my $line = $params{line};
50             @candidates = ($dbline{$line} && $dbline{$line}->{$type})
51 0 0 0       ? @{ $dbline{$line}->{$type}}
  0            
52             : ();
53             }
54            
55 0 0         if ($params{code}) {
56 0           @candidates = grep { $_->{code} eq $params{code} }
  0            
57             @candidates;
58             }
59              
60 0 0         if ($params{inactive}) {
61 0           @candidates = grep { $_->{inactive} eq $params{inactive} }
  0            
62             @candidates;
63             }
64              
65 0           return @candidates;
66             }
67              
68             sub _insert {
69 0     0     my $self = shift;
70              
71             # Setting items in the breakpoint hash only gets
72             # its magical DB-stopping abilities if you're in
73             # pacakge DB. Otherwise, you can alter the breakpoint
74             # data, other users will see them, but the debugger
75             # won't stop
76             package DB;
77 0           our %dbline;
78 0           local(*dbline) = $main::{'_<' . $self->file};
79              
80 0   0       my $bp_info = $dbline{$self->line} ||= {};
81 0           my $type = $self->type;
82 0   0       $bp_info->{$type} ||= [];
83 0           push @{$bp_info->{$type}}, $self;
  0            
84             }
85              
86             sub delete {
87 0     0 1   my $self = shift;
88              
89 0           my($file, $line, $code, $type, $self_ref);
90 0 0         if (ref $self) {
91 0           ($file, $line, $code) = map { $self->$_ } qw(file line code);
  0            
92 0           $type = $self->type;
93 0           $self_ref = $self . '';
94             } else {
95 0           my %params = __required([qw(file line code type)], @_);
96 0           ($file, $line, $code, $type) = @params{'file','line','code','type'};
97             }
98              
99 0           our %dbline;
100 0           local(*dbline) = $main::{'_<' . $file};
101 0           my $bp_info = $dbline{$line};
102 0 0 0       return unless ($bp_info && $bp_info->{$type});
103              
104 0           my $bp_list = $bp_info->{$type};
105 0           for (my $i = 0; $i < @$bp_list; $i++) {
106 0           my($its_file, $its_line, $its_code) = map { $bp_list->[$i]->$_ } qw(file line code);
  0            
107 0 0 0       if ($file eq $its_file
    0 0        
      0        
108             and
109             $line == $its_line
110             and
111             $code eq $its_code
112             and
113             ( defined($self_ref) ? $self_ref eq $bp_list->[$i] : 1 )
114             ) {
115 0           splice(@$bp_list, $i, 1);
116 0           last;
117             }
118             }
119              
120 0 0         if (! @$bp_list) {
121             # last breakpoint/action removed for this line
122 0           delete $bp_info->{$type};
123             }
124              
125 0 0         if (! %$bp_info) {
126             # No breakpoints or actions left on this line
127 0           $dbline{$line} = undef;
128             }
129 0           return $self;
130             }
131              
132            
133 0     0 1   sub file { return shift->{file} }
134 0     0 1   sub line { return shift->{line} }
135 0     0 1   sub once { return shift->{once} }
136 0   0 0 0   sub type { my $class = shift; $class = ref($class) || $class; die "$class didn't implement method type" }
  0            
  0            
137              
138             sub code {
139 0     0 1   my $self = shift;
140 0 0         if (@_) {
141 0           $self->{code} = shift;
142             }
143 0           return $self->{code};
144             }
145              
146             sub inactive {
147 0     0 1   my $self = shift;
148 0 0         if (@_) {
149 0           $self->{inactive} = shift;
150             }
151 0           return $self->{inactive};
152             }
153              
154             package Devel::Chitin::Breakpoint;
155              
156 34     34   233 use base 'Devel::Chitin::Actionable';
  34         55  
  34         6214  
157              
158             sub new {
159 0     0     my($class, %params) = @_;
160 0 0         $params{code} = 1 unless (exists $params{code});
161 0           $class->SUPER::new(%params);
162             }
163              
164             sub type() { 'condition' };
165              
166             package Devel::Chitin::Action;
167              
168 34     34   195 use base 'Devel::Chitin::Actionable';
  34         57  
  34         3035  
169              
170             sub type() { 'action' };
171              
172             1;
173              
174             __END__