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

package Devel::Chitin::Actionable;

use strict;
use warnings;

our $VERSION = '0.15';

use Digest::MD5 qw(md5);
use Carp;

sub new {
    my $class = shift;

    my %params = __required([qw(file line code)], @_);

    my $self = \%params;
    bless $self, $class;
    $self->_insert();
    return $self;
}

sub __required {
    my $required_params = shift;
    my %params = @_;
    do { defined($params{$_}) || Carp::croak("$_ is a required param") }
        foreach @$required_params;
    return %params;
}

sub get {
    my $class = shift;
    return $class if (ref $class);

    my %params = __required([qw(file)], @_);

    our %dbline;
    local(*dbline) = $main::{'_<' . $params{file}};
    return unless %dbline;

    my @candidates;

    my $type = $class->type;
    if (!$params{line}) {
        @candidates =
              map { $_->{$type} ? @{$_->{$type}} : () } # only lines with the type we're looking for
              grep { $_ }      # only lines with something
              values %dbline;  # All action/breakpoint data for this file
    } else {
        my $line = $params{line};
        @candidates = ($dbline{$line} && $dbline{$line}->{$type})
                    ? @{ $dbline{$line}->{$type}}
                    : ();
    }

    if ($params{code}) {
        @candidates = grep { $_->{code} eq $params{code} }
                        @candidates;
    }

    if ($params{inactive}) {
        @candidates = grep { $_->{inactive} eq $params{inactive} }
                        @candidates;
    }

    return @candidates;
}

sub _insert {
    my $self = shift;

    # Setting items in the breakpoint hash only gets
    # its magical DB-stopping abilities if you're in
    # pacakge DB.  Otherwise, you can alter the breakpoint
    # data, other users will see them, but the debugger
    # won't stop
    package DB;
    our %dbline;
    local(*dbline) = $main::{'_<' . $self->file};

    my $bp_info = $dbline{$self->line} ||= {};
    my $type = $self->type;
    $bp_info->{$type} ||= [];
    push @{$bp_info->{$type}}, $self;
}

sub delete {
    my $self = shift;

    my($file, $line, $code, $type, $self_ref);
    if (ref $self) {
        ($file, $line, $code) = map { $self->$_ } qw(file line code);
        $type = $self->type;
        $self_ref = $self . '';
    } else {
        my %params = __required([qw(file line code type)], @_);
        ($file, $line, $code, $type) = @params{'file','line','code','type'};
    }

    our %dbline;
    local(*dbline) = $main::{'_<' . $file};
    my $bp_info = $dbline{$line};
    return unless ($bp_info && $bp_info->{$type});

    my $bp_list = $bp_info->{$type};
    for (my $i = 0; $i < @$bp_list; $i++) {
        my($its_file, $its_line, $its_code) = map { $bp_list->[$i]->$_ } qw(file line code);
        if ($file eq $its_file
            and
            $line == $its_line
            and
            $code eq $its_code
            and
            ( defined($self_ref) ? $self_ref eq $bp_list->[$i] : 1 )
        ) {
            splice(@$bp_list, $i, 1);
            last;
        }
    }

    if (! @$bp_list) {
        # last breakpoint/action removed for this line
        delete $bp_info->{$type};
    }

    if (! %$bp_info) {
        # No breakpoints or actions left on this line
        $dbline{$line} = undef;
    }
    return $self;
}


sub file    { return shift->{file} }
sub line    { return shift->{line} }
sub once    { return shift->{once} }
sub type    { my $class = shift;  $class = ref($class) || $class; die "$class didn't implement method type" }

sub code    {
    my $self = shift;
    if (@_) {
        $self->{code} = shift;
    }
    return $self->{code};
}

sub inactive {
    my $self = shift;
    if (@_) {
        $self->{inactive} = shift;
    }
    return $self->{inactive};
}

package Devel::Chitin::Breakpoint;

use base 'Devel::Chitin::Actionable';

sub new {
    my($class, %params) = @_;
    $params{code} = 1 unless (exists $params{code});
    $class->SUPER::new(%params);
}

sub type() { 'condition' };

package Devel::Chitin::Action;

use base 'Devel::Chitin::Actionable';

sub type() { 'action' };

1;

__END__