Prima::EventHook - event filtering

	use Prima::EventHook;

	sub hook
	{
		my ( $my_param, $object, $event, @params) = @_;
		...
		print "Object $object received event $event\n";
		...
		return 1;
	}

	Prima::EventHook::install( \&hook, 
		param    => $my_param,
		object   => $my_window, 
		event    => [qw(Size Move Destroy)],
		children => 1
	);

	Prima::EventHook::deinstall(\&hook);

# $Id$
#
#  Copyright (c) 1997-2004 Dmitry Karasik
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  Created by Dmitry Karasik <dmitry@karasik.eu.org>
#
#  $Id$
use strict;

package Prima::EventHook;
use vars qw($hook $auto_hook %hooks %groups);

$auto_hook = 1;

%groups = (
	keyboard   => [qw(KeyDown KeyUp TranslateAccel)],
	mouse      => [qw(MouseDown MouseUp MouseMove MouseClick MouseEnter MouseLeave MouseWheel)],
	geometry   => [qw(Size Move ZOrderChanged)],
	objects    => [qw(ChangeOwner ChildEnter ChildLeave Create Destroy)],
	focus      => [qw(Leave Enter)],
	visibility => [qw(Hide Show)],
	ability    => [qw(Enable Disable)],
	menu       => [qw(Menu Popup)],
);

sub install
{
	my ( $sub, %rules) = @_;
	
	my @params;
	if ( defined($rules{param})) {
		@params = ( ref($rules{param}) eq 'ARRAY') ? @{$rules{param}} : $rules{param};
	}
	
	my @names;
	if ( defined($rules{event})) {
		@names = ( ref($rules{event}) eq 'ARRAY') ? @{$rules{event}} : $rules{event};
	} else {
		@names = ('*');
	}
	@names = map { exists($groups{$_}) ? @{$groups{$_}} : $_} @names;

	my @objects;
	if ( defined($rules{object})) {
		@objects = ( ref($rules{object}) eq 'ARRAY') ? @{$rules{object}} : $rules{object};
	} else {
		@objects = (undef);
	}
	
	for (@names) {
		$hooks{$_} = [] unless $hooks{$_};
		my $array = $hooks{$_};
		for ( @objects) {
			push @$array, [$sub, $_, $rules{children}, @params];
		}
	}

	Prima::Component-> event_hook( $hook = \&hook_proc) 
		if $auto_hook && !$hook;
}

sub deinstall
{
	my $sub = $_[0];
	my $total = 0;
	for ( keys %hooks) {
		@{$hooks{$_}} = grep { $$_[0] != $sub } @{$hooks{$_}};
		$total += @{$hooks{$_}};
	}
	Prima::Component-> event_hook( $hook = undef) 
		if !$total && $hook && $auto_hook;
}

sub hook_proc
{
	my ( $object, $event, @params) = @_;
	for ( '*', $event) {
		next unless exists $hooks{$_};
		for ( @{$hooks{$_}}) {
			my ( $sub, $sub_object, $sub_children, @sub_params) = @$_;
			next if 
				defined $sub_object &&
				(
					(  $sub_children && $sub_object-> is_owner( $object) == 0) ||
					( !$sub_children && $sub_object != $object)
				);
			return 0 unless $sub-> ( @sub_params, $object, $event, @params);
		}
	}
	return 1;
}

1;

__DATA__