perllib/FVWM/Event.pm

   1 # Copyright (c) 2003-2009 Mikhael Goikhman
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the Free Software
  15 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16
  17 package FVWM::Event;
  18
  19 use strict;
  20 use FVWM::EventNames;
  21
  22 sub new ($$$) {
  23         my $class = shift;
  24         my $type = shift;
  25         my $arg_values = shift;
  26
  27         my $is_special = defined $arg_values ? 0 : 1;
  28         my $is_extended = $type & M_EXTENDED_MSG ? 1 : 0;
  29
  30         $arg_values ||= [];
  31         $arg_values = event_arg_values($is_special ? "faked" : $type, $arg_values)
  32                 unless ref($arg_values);
  33
  34         my $self = {
  35                 type => $type,
  36                 args => undef,  # lazy hash of event arguments
  37                 arg_values => $arg_values,
  38                 propagation_allowed => 1,
  39                 is_special => $is_special,
  40                 is_extended => $is_extended,
  41         };
  42
  43         bless $self, $class;
  44
  45         return $self;
  46 }
  47
  48 sub type ($) {
  49         my $self = shift;
  50         return $self->{'type'};
  51 }
  52
  53 sub arg_values ($) {
  54         my $self = shift;
  55         return $self->{'arg_values'};
  56 }
  57
  58 sub arg_names ($) {
  59         my $self = shift;
  60         return event_arg_names($self->type, $self->arg_values);
  61 }
  62
  63 sub arg_types ($) {
  64         my $self = shift;
  65         return event_arg_types($self->type, $self->arg_values);
  66 }
  67
  68 sub loop_arg_names ($) {
  69         my $self = shift;
  70         return event_loop_arg_names($self->type, $self->arg_values);
  71 }
  72
  73 sub loop_arg_types ($) {
  74         my $self = shift;
  75         return event_loop_arg_types($self->type, $self->arg_values);
  76 }
  77
  78 sub args ($) {
  79         my $self = shift;
  80         $self->{'args'} ||= event_args($self->type, $self->arg_values);
  81         return $self->{'args'};
  82 }
  83
  84 sub is_extended ($) {
  85         my $self = shift;
  86         return $self->{'is_extended'};
  87 }
  88
  89 sub name ($) {
  90         my $self = shift;
  91         return event_name($self->type);
  92 }
  93
  94 sub propagation_allowed ($;$) {
  95         my $self = shift;
  96         my $value = shift;
  97         $self->{'propagation_allowed'} = $value if defined $value;
  98
  99         return $self->{'propagation_allowed'};
 100 }
 101
 102 sub dump ($) {
 103         my $self = shift;
 104         my $args = $self->args;
 105         my $string = $self->name . "\n";
 106
 107         my @arg_names  = @{$self->arg_names};
 108         my @arg_types  = @{$self->arg_types};
 109         my @arg_values = @{$self->arg_values};
 110
 111         while (@arg_names) {
 112                 my $name  = shift @arg_names;
 113                 my $type  = shift @arg_types;
 114                 my $value = shift @arg_values;
 115
 116                 my $text;
 117                 if ($type == FVWM::EventNames::number) {
 118                         $text = $value;
 119                         $text = "*undefined*" unless defined $value;
 120                 } elsif ($type == FVWM::EventNames::bool) {
 121                         $text = $value? "True": "False";
 122                 } elsif ($type == FVWM::EventNames::window) {
 123                         $text = sprintf("0x%07lx", $value);
 124                 } elsif ($type == FVWM::EventNames::pixel) {
 125                         $text = "rgb:" . join('/',
 126                                 sprintf("%06lx", $value) =~ /(..)(..)(..)/);
 127                 } elsif ($type == FVWM::EventNames::string) {
 128                         $value =~ s/"/\\"/g;
 129                         $text = qq("$value");
 130                 } elsif ($type == FVWM::EventNames::looped) {
 131                         my $loop_arg_names = $self->loop_arg_names;
 132                         my $loop_arg_types = $self->loop_arg_types;
 133                         my $j = 0;
 134                         while ($j < @$value) {
 135                                 my $k = 0;
 136                                 foreach (@$loop_arg_names) {
 137                                         my $i = int($j / @$loop_arg_names) + 1;
 138                                         push @arg_names, "[$i] $_";
 139                                         push @arg_types, $loop_arg_types->[$k];
 140                                         push @arg_values, $value->[$j];
 141                                         $j++; $k++;
 142                                 }
 143                         }
 144                         $text = sprintf("(%d)", @$value / @$loop_arg_names);
 145                 } elsif ($type == FVWM::EventNames::wflags) {
 146                         $text = qq([window flags are not supported yet]);
 147                 } else {
 148                         $text = qq([unsupported arg type $type] "$value");
 149                 }
 150
 151                 my $name_len = 12;
 152                 $name_len = int((length($name) + 5) / 6) * 6
 153                         if length($name) > $name_len;
 154                 $string .= sprintf "\t%-${name_len}s %s\n", $name, $text;
 155         }
 156         return $string;
 157 }
 158
 159 sub AUTOLOAD ($;@) {
 160         my $self = shift;
 161         my @params = @_;
 162
 163         my $method = $FVWM::Event::AUTOLOAD;
 164
 165         # remove the package name
 166         $method =~ s/.*://g;
 167         # DESTROY messages should never be propagated
 168         return if $method eq 'DESTROY';
 169
 170         if ($method =~ s/^_//) {
 171                 my $arg_value = $self->args->{$method};
 172                 return $arg_value if defined $arg_value;
 173
 174                 my $alias = event_arg_aliases($self->type)->{$method} || '*none*';
 175                 $arg_value = $self->args->{$alias};
 176                 return $arg_value if defined $arg_value;
 177
 178                 die "Unknown argument $method for event " . $self->name . "\n";
 179         }
 180
 181         die "Unknown method $method on $self called\n";
 182 }
 183
 184 # ----------------------------------------------------------------------------
 185
 186 =head1 NAME
 187
 188 FVWM::Event - the fvwm event object passed to event handlers
 189
 190 =head1 SYNOPSIS
 191
 192   use lib `fvwm-perllib dir`;
 193   use FVWM::Module;
 194
 195   my $module = new FVWM::Module(Mask => M_FOCUS_CHANGE);
 196
 197   # auto-raise all windows
 198   sub auto_raise ($$) {
 199       my ($module, $event) = @_;
 200       $module->debug("Got " . $event->name . "\n");
 201       $module->debug("\t$_: " . $event->args->{$_} . "\n")
 202           foreach sort keys %{$event->args};
 203       $module->send("Raise", $event->_win_id);
 204   }
 205   $module->add_handler(M_FOCUS_CHANGE, \&auto_raise);
 206
 207   $module->event_loop;
 208
 209 =head1 DESCRIPTION
 210
 211 To be written.
 212
 213 =head1 METHODS
 214
 215 =over 4
 216
 217 =item B<new> I<type> I<arg_values>
 218
 219 Constructs event object of the given I<type>.
 220 I<arg_values> is either an array ref of event's arguments (every event type
 221 has its own argument list, see L<FVWM::EventNames>) or a packed string of
 222 these arguments as received from the I<fvwm> pipe.
 223
 224 =item B<type>
 225
 226 Returns event's type (usually long integer).
 227
 228 =item B<arg_names>
 229
 230 Returns an array ref of the event argument names.
 231
 232     print "$_ " foreach @{$event->arg_names});
 233
 234 Note that this array of names is statical for any given event type.
 235
 236 =item B<arg_types>
 237
 238 Returns an array ref of the event argument types.
 239
 240     print "$_ " foreach @{$event->arg_types});
 241
 242 Note that this array of types is statical for any given event type.
 243
 244 =item B<loop_arg_names>
 245
 246 Returns an array ref of the looped argument names of the event (or undef).
 247
 248 =item B<loop_arg_types>
 249
 250 Returns an array ref of the looped argument types of the event (or undef).
 251
 252 =item B<arg_values>
 253
 254 Returns an array ref of the event argument values.
 255 In the previous versions of the library, all argument values were passed
 256 to event handlers, now only one event object is passed. Calling this
 257 method is the way to emulate the old behaviour.
 258
 259 Note that you should know the order of arguments, so the suggested way
 260 is to use C<args> instead, although it is a bit slower.
 261
 262 =item B<args>
 263
 264 Returns hash ref of the named event argument values.
 265
 266     print "[Debug] Got event ", $event->type, " with args:\n";
 267     while (($name, $value) = each %{$event->args})
 268         { print "\t$name: $value\n"; }
 269
 270 =item B<is_extended>
 271
 272 For technical reasons there are 2 categories of fvwm events, regular and
 273 extended. This was done to enable more events. With introdution of the
 274 extended event types (with the highest bit set) it is now possible to have
 275 31+31=62 different event types rather than 32. This is a good point, the bad
 276 point is that only event types of the same category may be masked (or-ed)
 277 together. This method returns 1 or 0 depending on whether the event is
 278 extended or not.
 279
 280 =item B<name>
 281
 282 Returns a string representing the event name (like "M_ADD_WINDOW"), it is
 283 the same as the corresponding C/Perl constant. May be (and in fact is)
 284 used for debugging.
 285
 286 =item B<propagation_allowed> [I<bool>]
 287
 288 Sets or returns a boolean value that indicates enabling or disabling of
 289 this event propagation.
 290
 291 =item B<dump>
 292
 293 Returns a string representation of the event object, basically the event
 294 name and all argument name=value lines.
 295
 296 =item B<_>I<name>
 297
 298 This is a shortcut for $event->args->{'I<name>'}. Returns the named event
 299 argument. See L<FVWM::EventNames> for names of all event argument names.
 300
 301 =back
 302
 303 =head1 AUTHOR
 304
 305 Mikhael Goikhman <migo@homemail.com>.
 306
 307 =head1 SEE ALSO
 308
 309 For more information, see L<fvwm>, L<FVWM::Module>, L<FVWM::Constants> and
 310 L<FVWM::EventNames>.
 311
 312 =cut
 313
 314 1;