SDL::App::FPS::EventHandler - an event handler class for SDL::App::FPS

	my $handler = SDL::App::FPS::EventHandler->new( $app,
		SDL_KEYDOWN,
		SDLK_SPACE,
		sub { my $self = shift; $self->pause(); },
	};

	my $handler2 = SDL::App::FPS::EventHandler->new( $app,
		SDL_MOUSEBUTTONDOWN,
		LEFTMOUSEBUTTON,
		sub { my $self = shift; $self->time_warp(2,2000); },
	};

	&{$callback}($self,$handler,$event);

# EventHandler class for SDL::App::FPS - used to register callbacks for events

package SDL::App::FPS::EventHandler;

# (C) by Tels <http://bloodgate.com/>

use strict;

use Exporter;
use SDL::App::FPS::Thingy;
use vars qw/@ISA $VERSION @EXPORT_OK/;
@ISA = qw/SDL::App::FPS::Thingy Exporter/;

@EXPORT_OK = qw/char2key char2type_kind FPS_EVENT/;

use SDL;

$VERSION = '0.05';

##############################################################################
# constants

sub FPS_EVENT () { -1; }

sub BUTTON_MOUSE_LEFT ()        { 1; }
sub BUTTON_MOUSE_RIGHT ()       { 4; }
sub BUTTON_MOUSE_MIDDLE ()      { 2; }
sub BUTTON_MOUSE_WHEEL_DOWN ()  { 8; }
sub BUTTON_MOUSE_WHEEL_UP ()    { 16; }

##############################################################################
# methods

sub _init
  {
  my $self = shift;

  $self->{type} = shift;
  $self->{kind} = shift;
  $self->{callback} = shift;
  
  $self->{args} = [ @_ ];

  $self->_init_mod();
  }

my $remap = {
  SDLK_LSHIFT() => KMOD_LSHIFT,
  SDLK_RSHIFT() => KMOD_RSHIFT,
  SDLK_LCTRL() => KMOD_LCTRL,
  SDLK_RCTRL() => KMOD_RCTRL,
  SDLK_LALT() => KMOD_LALT,
  SDLK_RALT() => KMOD_RALT,
  };

sub _init_mod
  { 
  my $self = shift;

  $self->{mod} = { };
  if (ref($self->{kind}) eq 'ARRAY')
    {
    # [ SLDK_a, SLDK_LSHIFT, ... ]
    my $mod = $self->{kind};
    $self->{kind} = $mod->[0];
    shift @{$mod};
    # convert @$mod to %$mod
    foreach my $m (@$mod)
      {
      if (exists $remap->{$m})
        {
        # silently remap SLDK_LSHIFT => KMOD_LSHIFT
        $self->{mod}->{$remap->{$m}} = 1;
        }
      else
        { 
        $self->{mod}->{$m} = 1;
        }
      }
    $self->{ignore_mod} = 0;			# don't ignore additionals
    }
  else
    {
    $self->{ignore_mod} = 1;			# do ignore additionals
    }
  $self->{require_all} = 0;			# don't require all of them
  $self;
  }

sub ignore_additional_modifiers
  {
  my $self = shift;

  if (@_ > 0)
    { 
    $self->{ignore_mod} = $_[0] ? 1 : 0;
    }
  $self->{ignore_mod};			
  }

sub require_all_modifiers
  {
  my $self = shift;

  if (@_ > 0)
    { 
    $self->{require_all} = $_[0] ? 1 : 0;
    }
  $self->{require_all};			
  }

sub check
  {
  # check whether the event matched the occured event or not
  my ($self,$event,$type,$key) = @_;

  return if $self->{active} == 0;

  return unless $type == $self->{type};

  if ($type == FPS_EVENT || $type == SDL_KEYDOWN || $type == SDL_KEYUP)
    {
    return unless $key eq $self->{kind};
    }
  elsif ($type == SDL_MOUSEBUTTONUP || $type == SDL_MOUSEBUTTONDOWN)
    {
    # watch for more than one button with one event:
    return if ($self->{kind} & $key) == 0;
    }

  my $required = 0;
  # find out which modifiers (these we watch) are pressed
  my $mods = $event->key_mod();
  foreach my $mod (keys %{$self->{mod}})
    {
    # this watched one is pressed
    if (($mods & $mod) != 0)
      {
      $required++;
      $mods -= $mod;				# eliminate this bit
      }
    }
  
  if ($self->{ignore_mod} != 1)
    {
    # $mods != 0 if there were additional modifiers and we don't ignore this
    return if $mods != 0;
    }


  # if not all of the required ones were pressed, and we require all
  return if $self->{require_all} != 0 &&
    $required != scalar keys %{$self->{mod}};
  
  # when we watch some modifiers, at least one must be pressed
  return if $required == 0 && scalar keys %{$self->{mod}} != 0;

  # event happened, so call callback
  &{$self->{callback}}($self->{app},$self,$event,@{$self->{args}});
  }

sub rebind ($$$)
  {
  my ($self) = shift;

  my $old_type = $self->{type};
  $self->{type} = shift;
  $self->{kind} = shift;
  $self->_init_mod();
  $self->{app}->_rebound_event_handler($self,$old_type);
  $self; 
  }

sub type ()
  {
  # return the type this event handler watches out for
  my $self = shift;
  $self->{type};
  }

sub kind ()
  {
  # return the kind this event handler watches out for
  my $self = shift;
  $self->{kind};
  }

my $char2key = {
  a => SDLK_a,
  b => SDLK_b,
  c => SDLK_c,
  d => SDLK_d,
  e => SDLK_e,
  f => SDLK_f,
  g => SDLK_g,
  h => SDLK_h,
  i => SDLK_i,
  j => SDLK_j,
  k => SDLK_k,
  l => SDLK_l,
  m => SDLK_m,
  n => SDLK_n,
  o => SDLK_o,
  p => SDLK_p,
  q => SDLK_q(),
  r => SDLK_r,
  s => SDLK_s,
  t => SDLK_t,
  u => SDLK_u,
  v => SDLK_v,
  w => SDLK_w,
  x => SDLK_x,
  y => SDLK_y,
  z => SDLK_z,
  
  A => [ SDLK_a, KMOD_SHIFT ],
  B => [ SDLK_b, KMOD_SHIFT ],
  C => [ SDLK_c, KMOD_SHIFT ],
  D => [ SDLK_d, KMOD_SHIFT ],
  E => [ SDLK_e, KMOD_SHIFT ],
  F => [ SDLK_f, KMOD_SHIFT ],
  G => [ SDLK_g, KMOD_SHIFT ],
  H => [ SDLK_h, KMOD_SHIFT ],
  I => [ SDLK_i, KMOD_SHIFT ],
  J => [ SDLK_j, KMOD_SHIFT ],
  K => [ SDLK_k, KMOD_SHIFT ],
  L => [ SDLK_l, KMOD_SHIFT ],
  M => [ SDLK_m, KMOD_SHIFT ],
  N => [ SDLK_n, KMOD_SHIFT ],
  O => [ SDLK_o, KMOD_SHIFT ],
  P => [ SDLK_p, KMOD_SHIFT ],
  Q => [ SDLK_q, KMOD_SHIFT ],
  R => [ SDLK_r, KMOD_SHIFT ],
  S => [ SDLK_s, KMOD_SHIFT ],
  T => [ SDLK_t, KMOD_SHIFT ],
  U => [ SDLK_u, KMOD_SHIFT ],
  V => [ SDLK_v, KMOD_SHIFT ],
  W => [ SDLK_w, KMOD_SHIFT ],
  X => [ SDLK_x, KMOD_SHIFT ],
  Y => [ SDLK_y, KMOD_SHIFT ],
  Z => [ SDLK_z, KMOD_SHIFT ],

  0 => SDLK_0,
  1 => SDLK_1,
  2 => SDLK_2,
  3 => SDLK_3,
  4 => SDLK_4,
  5 => SDLK_5,
  6 => SDLK_6,
  7 => SDLK_7,
  8 => SDLK_8,
  9 => SDLK_9,

  '!' => [ SDLK_1, KMOD_SHIFT ],
  '"' => [ SDLK_2, KMOD_SHIFT ],
  '§' => [ SDLK_3, KMOD_SHIFT ],
  '$' => [ SDLK_4, KMOD_SHIFT ],
  '%' => [ SDLK_5, KMOD_SHIFT ],
  '&' => [ SDLK_6, KMOD_SHIFT ],
  '/' => [ SDLK_7, KMOD_SHIFT ],
  '(' => [ SDLK_7, KMOD_SHIFT ],
  ')' => [ SDLK_8, KMOD_SHIFT ],
  '=' => [ SDLK_0, KMOD_SHIFT ],
  '_' => [ SDLK_MINUS, KMOD_SHIFT ],
  ';' => [ SDLK_COMMA, KMOD_SHIFT ],
  ':' => [ SDLK_PERIOD, KMOD_SHIFT ],
  '>' => [ SDLK_LESS, KMOD_SHIFT ],
  '*' => [ SDLK_PLUS, KMOD_SHIFT ],
  '@' => [ SDLK_q, KMOD_RALT ],

  };

# if we define these in $char2key, we could skip the costly eval. OTOH, the
# eval will be done only once, while $char2key wastes memory...

#        SDLK_END SDLK_EQUALS SDLK_ESCAPE SDLK_EURO SDLK_EXCLAIM SDLK_F1
#        SDLK_F10 SDLK_F11 SDLK_F12 SDLK_F13 SDLK_F14 SDLK_F15 SDLK_F2 SDLK_F3
#        SDLK_F4 SDLK_F5 SDLK_F6 SDLK_F7 SDLK_F8 SDLK_F9 SDLK_GREATER
#        SDLK_HASH SDLK_HELP SDLK_HOME SDLK_INSERT SDLK_KP0 SDLK_KP1 SDLK_KP2
#        SDLK_KP3 SDLK_KP4 SDLK_KP5 SDLK_KP6 SDLK_KP7 SDLK_KP8 SDLK_KP9
#        SDLK_KP_DIVIDE SDLK_KP_ENTER SDLK_KP_EQUALS SDLK_KP_MINUS
##        SDLK_KP_MULTIPLY SDLK_KP_PERIOD SDLK_KP_PLUS SDLK_LALT SDLK_LCTRL
#        SDLK_LEFT SDLK_LEFTBRACKET SDLK_LEFTPAREN SDLK_LESS SDLK_LMETA
#        SDLK_LSHIFT SDLK_LSUPER SDLK_MENU SDLK_MINUS SDLK_MODE SDLK_NUMLOCK
#        SDLK_PAGEDOWN SDLK_PAGEUP SDLK_PAUSE SDLK_PERIOD SDLK_PLUS SDLK_POWER
#        SDLK_PRINT SDLK_QUESTION SDLK_QUOTE SDLK_QUOTEDBL SDLK_RALT
##        SDLK_RCTRL SDLK_RETURN SDLK_RIGHT SDLK_RIGHTBRACKET SDLK_RIGHTPAREN
#        SDLK_RMETA SDLK_RSHIFT SDLK_RSUPER SDLK_SCROLLOCK SDLK_SEMICOLON
#        SDLK_SLASH SDLK_SPACE SDLK_SYSREQ SDLK_TAB SDLK_UNDERSCORE SDLK_UP

sub char2key
  {
  # convert a character like 'a' to a key event like SDLK_a
  my $char = shift;

  return $char2key->{$char} if exists $char2key->{$char};
  if ($char =~ /^[A-Z]A-Z+/)
    {
    $char = 'SDLK_' . $char if $char =~ /^SDLK_/;
    return eval "$char()";
    }
  return;  
  }

sub char2type_kind
  {
  # convert a character like 'a' to a key event like SDLK_a
  # and a string like "PRINT" to SDL_KEYDOWN, SDLK_PRINT
  my $key = shift;

  my $type = SDL_KEYDOWN;
  if ($key =~ /^([LMR]MB|MWD|MWU)$/)
    {
    $type = SDL_MOUSEBUTTONDOWN;
    if ($key eq 'LMB')
      {
      $key = BUTTON_MOUSE_LEFT;
      }
    elsif ($key eq 'RMB')
      {
      $key = BUTTON_MOUSE_RIGHT;
      }
    elsif ($key eq 'MMB')
      {
      $key = BUTTON_MOUSE_MIDDLE;
      }
    elsif ($key eq 'MWU')
      {
      $key = BUTTON_MOUSE_WHEEL_UP;
      }
    elsif ($key eq 'MWD')
      {
      $key = BUTTON_MOUSE_WHEEL_DOWN;
      }
    return ($type, $key);
    }

  # if passed something like "123", user passed SDLK_foo() as key.
  return ($type,$key) if $key =~ /^\d{2,}\z/;

  return ($type,$char2key->{$key}) if exists $char2key->{$key};

  $key = "SDLK_$key" unless $key =~ /^SDLK_/;

  my $char = eval "$key()"; 
  ($type, $char);
  }

1;

__END__