File Coverage

lib/Devel/Trepan/CmdProcessor/Hook.pm

Criterion	Covered	Total	%
statement	51	73	69.8
branch	5	16	31.2
condition			n/a
subroutine	10	17	58.8
pod	0	7	0.0
total	66	113	58.4

# -*- coding: utf-8 -*-
# Copyright (C) 2011-2012 Rocky Bernstein <[e-mail]>
use strict; use warnings;
use rlib '../../..';

use Class::Struct;
use Time::HiRes;

struct CmdProcessorHook => {
    priority    => '$',
    name        => '$',
    fn          => '$'
};


package Devel::Trepan::CmdProcessor::Hook;
#  attr_accessor :list

sub new($;$)
{
    my ($class, $list) = @_;
    my $self = {};
    $list = [] unless defined $list;
    $self->{list} = $list;
    bless $self, $class;
    $self;
}

sub delete_by_name($)
{
    my ($self, $delete_name) = @_;
    my @new_list = ();
    for my $elt (@{$self->{list}}) {
        push(@new_list, $elt) unless $elt->name eq $delete_name;
    }
    $self->{list} = \@new_list;
}

sub is_empty($)
{
    my $self = shift;
    return 0 == scalar(@{$self->{list}});
}

sub insert($$$$)
{
    my ($self, $priority, $name, $hook) = @_;
    my $insert_loc;
    my @list = $self->{list};
    for ($insert_loc=0; $insert_loc < $#list; $insert_loc++) {
        my $entry = $self->{list}[$insert_loc];
        if ($priority > $entry->priority) {
            last;
        }
    }
    my $new_item = CmdProcessorHook->new(name => $name, priority=>$priority, fn => $hook);
    splice(@{$self->{list}}, $insert_loc, 0, $new_item);
}

sub insert_if_new($$$$)
{
    my ($self, $priority, $name, $hook) = @_;
    my $found = 0;
    for my $item (@{$self->{list}}) {
        if ($item->name eq $name) {
            $found = 1;
            last;
        }
    }
    $self->insert($priority, $name, $hook) unless ($found);
}

# Run each function in `hooks' with args
sub run($)
{
    my $self = shift;
    for my $hook (@{$self->{list}}) {
        $hook->fn->($hook->name, \@_);
    }
}

package Devel::Trepan::CmdProcessor;

# # Command processor hooks.
# attr_reader   :autolist_hook
# attr_reader   :timer_hook
# attr_reader   :trace_hook
# attr_reader   :tracebuf_hook
# attr_reader   :unconditional_prehooks
# attr_reader   :cmdloop_posthooks
# attr_reader   :cmdloop_prehooks

# # Used to time how long a debugger action takes
# attr_accessor :time_last

sub hook_initialize($)
{
    my ($self) = @_;
    my $commands = $self->{commands};
    $self->{cmdloop_posthooks}      = Devel::Trepan::CmdProcessor::Hook->new;
    $self->{cmdloop_prehooks}       = Devel::Trepan::CmdProcessor::Hook->new;
    $self->{unconditional_prehooks} = Devel::Trepan::CmdProcessor::Hook->new;

    my $list_cmd = $commands->{'list'};
    $self->{autolist_hook}  = ['autolist',
                               sub{ $list_cmd->run(['list']) if $list_cmd}];

    $self->{timer_hook}     = ['timer',
                               sub{
                                   my $now = Time::HiRes::time;
                                   $self->{time_last} = $now unless
                                       defined $self->{time_last};
                                   my $mess = sprintf("%g seconds", $now - $self->{time_last});
                                   $self->msg($mess);
                                   $self->{time_last} = $now;
                               }];
    $self->{timer_posthook} = ['timer',
                               sub{
                                   $self->{time_last} = Time::HiRes::time}];
    $self->{trace_hook}     = ['trace',
                               sub{
                                   $self->print_location unless
                                       $self->{terminated} } ];
    $self->{tracebuf_hook}  = ['tracebuffer',
                               sub{
                                   push(@{$self->{eventbuf}},
                                        ($self->{event}, $self->{frame}));
                               }];
}

unless (caller) {
    # Demo it.
    my $hooks = Devel::Trepan::CmdProcessor::Hook->new();
    $hooks->run(5);
    my $hook1 = sub($$) {
        my ($name, $a) = @_;
        my $args = join(', ', @$a);
        print "${name} called with $args\n";
    };
    $hooks = Devel::Trepan::CmdProcessor::Hook->new();
    $hooks->insert(-1, 'hook1', $hook1);
    $hooks->insert_if_new(-1, 'hook1', $hook1);
    my $dash_line = '-' x 30 . "\n";
    print $dash_line;
    print join(', ', @{$hooks->{list}}), "\n";
    $hooks->run(10);
    print $dash_line;
    $hooks->insert(-1, 'hook2', $hook1);
    $hooks->run(20);
    print $dash_line;
    $hooks->delete_by_name('hook2');
    $hooks->run(30);
    print $dash_line;
    $hooks->delete_by_name('hook1');
    $hooks->run(30);
    print $dash_line;
}

1;