package Tk::Signals;

use Tk::Widget;
use Tk;

use vars qw ($VERSION %SLOTS);
use strict;
use Carp;

$VERSION = '0.03';

sub GLOBALSLOT
   {
    Tk::Signals::__insertslothandler ($_[0], $_[1], \%Tk::Signals::SLOTS);
   }

sub SLOT
   {
    my $l_Toplevel = $_[0]->__findtoplevel();
    $l_Toplevel->{'Tk::Signals::SLOTS'} = {} unless (defined ($l_Toplevel->{'Tk::Signals::SLOTS'}));
    Tk::Signals::__insertslothandler ($_[0], $_[1], $l_Toplevel->{'Tk::Signals::SLOTS'});
   }

sub SIGNAL
   {
    my ($p_Self, $p_Signal, @p_Arguments) = (shift, @_);

    return unless (defined ($p_Signal) && defined ($p_Self));

    my @l_WidgetList;
    my %l_Hash;

    foreach my $l_Reference ($p_Self->__findtoplevel()->{'Tk::Signals::SLOTS'}->{$p_Signal}, $Tk::Signals::SLOTS {$p_Signal})
       {
        foreach my $l_Widget (@{$l_Reference})
           {
            unless ($l_Hash {$l_Widget})
               {
                push (@l_WidgetList, $l_Widget);
                $l_Hash {$l_Widget} = 1;
               }
           }
       }

    foreach my $l_Widget (@l_WidgetList)
       {
        no strict 'refs';
        next unless (Exists ($l_Widget));
        my $l_Callback = $l_Widget->{'__Tk::Signal::ClassName'}.'::'.$p_Signal;
        next unless $l_Widget->can ($l_Callback);
        &{$l_Callback} ($l_Widget, @p_Arguments);
        use strict 'refs';
       }
   }

sub __findtoplevel
   {
    my $l_Toplevel = $_[0]->toplevel();

    while (ref ($l_Toplevel) ne 'Tk::Toplevel' && ref ($l_Toplevel) ne 'Tk::MainWindow' && defined ($l_Toplevel->parent()))
       {
        $l_Toplevel = $l_Toplevel->parent()->toplevel();
       }

    return $l_Toplevel;
   }

sub __insertslothandler
   {
    my ($l_Found, $p_Self, $p_Signal, $p_Reference) = (0, shift, @_);

    return unless (defined ($p_Signal) && defined ($p_Self) && defined ($p_Reference));

    foreach my $l_Search (@{$p_Reference->{$p_Signal}})
       {
        $l_Found = 1 if ($l_Search eq $p_Self);
       }

    unless ($l_Found)
       {
        $p_Self->{'__Tk::Signal::ClassName'} = ref ($p_Self);
        push (@{$p_Reference->{$p_Signal}}, $p_Self);
       }
   }

1;