File Coverage

blib/lib/Tk/SignalSlot.pm

Criterion	Covered	Total	%
statement	9	40	22.5
branch	0	12	0.0
condition	0	6	0.0
subroutine	3	7	42.8
pod	3	3	100.0
total	15	68	22.0

package Tk::SignalSlot;

use strict;
use Carp;

our $VERSION = 0.1;

my %connected;
my @ids;
my $newID = 0;

sub connect {
    my ($parent, $event, $code) = @_;

    unless ($event && $code) {
	croak "connect usage - need an event description and a callback";
    }

    # create the callback object.
    my $cb = Tk::Callback->new($code);

    # if this is the first time we connect to this event,
    # create the Tk binding for it.
    unless (exists $connected{$parent}{$event}) {
	$parent->Tk::bind($event => sub {
	    $_ && $_->Call() for @{$connected{$parent}{$event}};
	});

	$connected{$parent}{$event} = [];
    }

    my $index = @{$connected{$parent}{$event}};
    $connected{$parent}{$event}[$index] = $cb;

    $ids[$newID] = [$parent, $event, $index];
    return $newID++;
}

sub disconnect {
    my ($w, $id) = @_;

    if ($id > $#ids) {
	carp "disconnect - Callback ID $id not defined!";
	return undef;
    }

    my ($parent, $event, $index) = @{$ids[$id]};

    unless (defined $connected{$parent}{$event}[$index]) {
	carp "disconnect - Callback ID $id already disconnected!";
	return undef;
    }

    $connected{$parent}{$event}[$index] = undef;

    return 1;
}

sub is_connected {
    my ($w, $id) = @_;

    return 0 if $id > $#ids;

    my ($parent, $event, $index) = @{$ids[$id]};
    return 0 unless defined $connected{$parent}{$event}[$index];

    return 1;
}

package Tk;

use strict;

*connect      = \&Tk::SignalSlot::connect;
*disconnect   = \&Tk::SignalSlot::disconnect;
*is_connected = \&Tk::SignalSlot::is_connected;

1;

__END__