Net/XMPP2/Event.pm

package Net::XMPP2::Event;
use strict;

=head1 NAME

Net::XMPP2::Event - Event handler class

=head1 SYNOPSIS

   package foo;
   use Net::XMPP2::Event;

   our @ISA = qw/Net::XMPP2::Event/;

   package main;
   my $o = foo->new;
   $o->reg_cb (foo => sub { ...; 1 });
   $o->event (foo => 1, 2, 3);

=head1 DESCRIPTION

This module is just a small helper module for the connection
and client classes.

You may only derive from this package.

=head1 METHODS

=over 4

=item B<reg_cb ($eventname1, $cb1, [$eventname2, $cb2, ...])>

This method registers a callback C<$cb1> for the event with the
name C<$eventname1>. You can also pass multiple of these eventname => callback
pairs.

The return value will be an ID that represents the set of callbacks you have installed.
Call C<unreg_cb> with that ID to remove those callbacks again.

To see a documentation of emitted events please take a look at the EVENTS section
in the classes that inherit from this one.

The callbacks will be called in an array context. If a callback doesn't want
to return any value it should return an empty list.
All elements of the returned list will be accumulated and the semantic of the
accumulated return values depends on the events.

=cut

sub reg_cb {
   my ($self, %regs) = @_;

   $self->{id}++;

   for my $cmd (keys %regs) {
      push @{$self->{events}->{lc $cmd}}, [$self->{id}, $regs{$cmd}]
   }

   $self->{id}
}

=item B<unreg_cb ($id)>

Removes the set C<$id> of registered callbacks. C<$id> is the
return value of a C<reg_cb> call.

=cut

sub unreg_cb {
   my ($self, $id) = @_;

   my $set = delete $self->{ids}->{$id};

   for my $key (keys %{$self->{events}}) {
      @{$self->{events}->{$key}} =
         grep {
            $_->[0] ne $id
         } @{$self->{events}->{$key}};
   }
}


=item B<event ($eventname, @args)>

Emits the event C<$eventname> and passes the arguments C<@args>.
The return value is a list of defined return values from the event callbacks.

=cut

sub event {
   my ($self, $ev, @arg) = @_;

   my $old_cb_state = $self->{cb_state};
   my @res;
   eval {
      my $nxt = [];

      for my $rev (@{$self->{events}->{lc $ev}}) {
         my $state = $self->{cb_state} = {};

         my (@r) = $rev->[1]->($self, @arg);

         push @$nxt, $rev unless $state->{remove};
         push @res, @r if @r;
      }
      $self->{events}->{lc $ev} = $nxt;

      for my $ev_frwd (keys %{$self->{event_forwards}}) {
         my $rev = $self->{event_forwards}->{$ev_frwd};
         my $state = $self->{cb_state} = {};

         my (@r) = $rev->[1]->($self, $rev->[0], $ev, @arg);

         if ($state->{remove}) {
            delete $self->{event_forwards}->{$ev_frwd};
         }

         push @res, @r if @r;
      }
   };
   if ($@) {
      warn "Uncaught exception: $@";
   }
   $self->{cb_state} = $old_cb_state;

   @res
}

=item B<unreg_me>

If this method is called from a callback on the first argument to the
callback (thats C<$self>) the callback will be deleted after it is finished.

=cut

sub unreg_me {
   my ($self) = @_;
   $self->{cb_state}->{remove} = 1;
}

=item B<add_forward ($obj, $forward_cb)>

This method allows to forward or copy all events to a object.
C<$forward_cb> will be called everytime an event is generated in C<$self>.
The first argument to the callback C<$forward_cb> will be <$self>, the second
will be C<$obj>, the third will be the event name and the rest will be
the event arguments. (For third and rest of argument also see description
of C<event>).

=cut

sub add_forward {
   my ($self, $obj, $forward_cb) = @_;
   $self->{event_forwards}->{$obj} = [$obj, $forward_cb];
}

=item B<remove_forward ($obj)>

This method removes a forward. C<$obj> must be the same
object that was given C<add_forward> as the C<$obj> argument.

=cut

sub remove_forward {
   my ($self, $obj) = @_;
   delete $self->{event_forwards}->{$obj};
}

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
Revision:	1.8
Committed:	Tue Jul 24 13:05:55 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.7:	+9 -4 lines
Log Message:	changed some events to reflect the new meaning of event callback return values.
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Event;
2	elmex	1.7	use strict;
3	elmex	1.1
4			=head1 NAME
5
6	elmex	1.5	Net::XMPP2::Event - Event handler class
7	elmex	1.1
8			=head1 SYNOPSIS
9
10			package foo;
11			use Net::XMPP2::Event;
12
13			our @ISA = qw/Net::XMPP2::Event/;
14
15			package main;
16			my $o = foo->new;
17			$o->reg_cb (foo => sub { ...; 1 });
18			$o->event (foo => 1, 2, 3);
19
20			=head1 DESCRIPTION
21
22			This module is just a small helper module for the connection
23			and client classes.
24
25			You may only derive from this package.
26
27	elmex	1.4	=head1 METHODS
28
29			=over 4
30
31			=item B<reg_cb ($eventname1, $cb1, [$eventname2, $cb2, ...])>
32	elmex	1.1
33			This method registers a callback C<$cb1> for the event with the
34			name C<$eventname1>. You can also pass multiple of these eventname => callback
35			pairs.
36
37	elmex	1.2	The return value will be an ID that represents the set of callbacks you have installed.
38			Call C<unreg_cb> with that ID to remove those callbacks again.
39
40	elmex	1.1	To see a documentation of emitted events please take a look at the EVENTS section
41	elmex	1.2	in the classes that inherit from this one.
42	elmex	1.1
43	elmex	1.8	The callbacks will be called in an array context. If a callback doesn't want
44			to return any value it should return an empty list.
45			All elements of the returned list will be accumulated and the semantic of the
46			accumulated return values depends on the events.
47
48	elmex	1.1	=cut
49
50			sub reg_cb {
51			my ($self, %regs) = @_;
52
53	elmex	1.2	$self->{id}++;
54
55	elmex	1.1	for my $cmd (keys %regs) {
56	elmex	1.2	push @{$self->{events}->{lc $cmd}}, [$self->{id}, $regs{$cmd}]
57	elmex	1.1	}
58
59	elmex	1.2	$self->{id}
60			}
61
62	elmex	1.4	=item B<unreg_cb ($id)>
63	elmex	1.2
64			Removes the set C<$id> of registered callbacks. C<$id> is the
65			return value of a C<reg_cb> call.
66
67			=cut
68
69			sub unreg_cb {
70			my ($self, $id) = @_;
71
72			my $set = delete $self->{ids}->{$id};
73
74			for my $key (keys %{$self->{events}}) {
75			@{$self->{events}->{$key}} =
76			grep {
77			$_->[0] ne $id
78			} @{$self->{events}->{$key}};
79			}
80	elmex	1.1	}
81
82	elmex	1.2
83	elmex	1.4	=item B<event ($eventname, @args)>
84	elmex	1.1
85			Emits the event C<$eventname> and passes the arguments C<@args>.
86	elmex	1.7	The return value is a list of defined return values from the event callbacks.
87	elmex	1.1
88			=cut
89
90			sub event {
91			my ($self, $ev, @arg) = @_;
92
93	elmex	1.7	my $old_cb_state = $self->{cb_state};
94			my @res;
95			eval {
96			my $nxt = [];
97
98			for my $rev (@{$self->{events}->{lc $ev}}) {
99			my $state = $self->{cb_state} = {};
100
101	elmex	1.8	my (@r) = $rev->[1]->($self, @arg);
102	elmex	1.7
103			push @$nxt, $rev unless $state->{remove};
104	elmex	1.8	push @res, @r if @r;
105	elmex	1.7	}
106			$self->{events}->{lc $ev} = $nxt;
107
108			for my $ev_frwd (keys %{$self->{event_forwards}}) {
109			my $rev = $self->{event_forwards}->{$ev_frwd};
110			my $state = $self->{cb_state} = {};
111
112	elmex	1.8	my (@r) = $rev->[1]->($self, $rev->[0], $ev, @arg);
113	elmex	1.7
114			if ($state->{remove}) {
115			delete $self->{event_forwards}->{$ev_frwd};
116			}
117
118	elmex	1.8	push @res, @r if @r;
119	elmex	1.7	}
120			};
121			if ($@) {
122			warn "Uncaught exception: $@";
123			}
124			$self->{cb_state} = $old_cb_state;
125
126			@res
127			}
128
129			=item B<unreg_me>
130	elmex	1.1
131	elmex	1.7	If this method is called from a callback on the first argument to the
132			callback (thats C<$self>) the callback will be deleted after it is finished.
133	elmex	1.1
134	elmex	1.7	=cut
135	elmex	1.3
136	elmex	1.7	sub unreg_me {
137			my ($self) = @_;
138			$self->{cb_state}->{remove} = 1;
139	elmex	1.1	}
140
141	elmex	1.4	=item B<add_forward ($obj, $forward_cb)>
142	elmex	1.3
143			This method allows to forward or copy all events to a object.
144	elmex	1.5	C<$forward_cb> will be called everytime an event is generated in C<$self>.
145	elmex	1.3	The first argument to the callback C<$forward_cb> will be <$self>, the second
146			will be C<$obj>, the third will be the event name and the rest will be
147			the event arguments. (For third and rest of argument also see description
148			of C<event>).
149
150			=cut
151
152			sub add_forward {
153			my ($self, $obj, $forward_cb) = @_;
154			$self->{event_forwards}->{$obj} = [$obj, $forward_cb];
155			}
156
157	elmex	1.6	=item B<remove_forward ($obj)>
158
159			This method removes a forward. C<$obj> must be the same
160			object that was given C<add_forward> as the C<$obj> argument.
161
162			=cut
163
164			sub remove_forward {
165			my ($self, $obj) = @_;
166			delete $self->{event_forwards}->{$obj};
167			}
168
169	elmex	1.4	=back
170
171	elmex	1.1	=head1 AUTHOR
172
173	elmex	1.4	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
174	elmex	1.1
175			=head1 COPYRIGHT & LICENSE
176
177			Copyright 2007 Robin Redeker, all rights reserved.
178
179			This program is free software; you can redistribute it and/or modify it
180			under the same terms as Perl itself.
181
182			=cut
183
184			1;