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.

=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 defined $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 defined $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.7
Committed:	Tue Jul 24 12:31:15 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.6:	+45 -9 lines
Log Message:	documentation update
#	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			=cut
44
45			sub reg_cb {
46			my ($self, %regs) = @_;
47
48	elmex	1.2	$self->{id}++;
49
50	elmex	1.1	for my $cmd (keys %regs) {
51	elmex	1.2	push @{$self->{events}->{lc $cmd}}, [$self->{id}, $regs{$cmd}]
52	elmex	1.1	}
53
54	elmex	1.2	$self->{id}
55			}
56
57	elmex	1.4	=item B<unreg_cb ($id)>
58	elmex	1.2
59			Removes the set C<$id> of registered callbacks. C<$id> is the
60			return value of a C<reg_cb> call.
61
62			=cut
63
64			sub unreg_cb {
65			my ($self, $id) = @_;
66
67			my $set = delete $self->{ids}->{$id};
68
69			for my $key (keys %{$self->{events}}) {
70			@{$self->{events}->{$key}} =
71			grep {
72			$_->[0] ne $id
73			} @{$self->{events}->{$key}};
74			}
75	elmex	1.1	}
76
77	elmex	1.2
78	elmex	1.4	=item B<event ($eventname, @args)>
79	elmex	1.1
80			Emits the event C<$eventname> and passes the arguments C<@args>.
81	elmex	1.7	The return value is a list of defined return values from the event callbacks.
82	elmex	1.1
83			=cut
84
85			sub event {
86			my ($self, $ev, @arg) = @_;
87
88	elmex	1.7	my $old_cb_state = $self->{cb_state};
89			my @res;
90			eval {
91			my $nxt = [];
92
93			for my $rev (@{$self->{events}->{lc $ev}}) {
94			my $state = $self->{cb_state} = {};
95
96			my $r = $rev->[1]->($self, @arg);
97
98			push @$nxt, $rev unless $state->{remove};
99			push @res, $r if defined $r;
100			}
101			$self->{events}->{lc $ev} = $nxt;
102
103			for my $ev_frwd (keys %{$self->{event_forwards}}) {
104			my $rev = $self->{event_forwards}->{$ev_frwd};
105			my $state = $self->{cb_state} = {};
106
107			my $r = $rev->[1]->($self, $rev->[0], $ev, @arg);
108
109			if ($state->{remove}) {
110			delete $self->{event_forwards}->{$ev_frwd};
111			}
112
113			push @res, $r if defined $r;
114			}
115			};
116			if ($@) {
117			warn "Uncaught exception: $@";
118			}
119			$self->{cb_state} = $old_cb_state;
120
121			@res
122			}
123
124			=item B<unreg_me>
125	elmex	1.1
126	elmex	1.7	If this method is called from a callback on the first argument to the
127			callback (thats C<$self>) the callback will be deleted after it is finished.
128	elmex	1.1
129	elmex	1.7	=cut
130	elmex	1.3
131	elmex	1.7	sub unreg_me {
132			my ($self) = @_;
133			$self->{cb_state}->{remove} = 1;
134	elmex	1.1	}
135
136	elmex	1.4	=item B<add_forward ($obj, $forward_cb)>
137	elmex	1.3
138			This method allows to forward or copy all events to a object.
139	elmex	1.5	C<$forward_cb> will be called everytime an event is generated in C<$self>.
140	elmex	1.3	The first argument to the callback C<$forward_cb> will be <$self>, the second
141			will be C<$obj>, the third will be the event name and the rest will be
142			the event arguments. (For third and rest of argument also see description
143			of C<event>).
144
145			=cut
146
147			sub add_forward {
148			my ($self, $obj, $forward_cb) = @_;
149			$self->{event_forwards}->{$obj} = [$obj, $forward_cb];
150			}
151
152	elmex	1.6	=item B<remove_forward ($obj)>
153
154			This method removes a forward. C<$obj> must be the same
155			object that was given C<add_forward> as the C<$obj> argument.
156
157			=cut
158
159			sub remove_forward {
160			my ($self, $obj) = @_;
161			delete $self->{event_forwards}->{$obj};
162			}
163
164	elmex	1.4	=back
165
166	elmex	1.1	=head1 AUTHOR
167
168	elmex	1.4	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
169	elmex	1.1
170			=head1 COPYRIGHT & LICENSE
171
172			Copyright 2007 Robin Redeker, all rights reserved.
173
174			This program is free software; you can redistribute it and/or modify it
175			under the same terms as Perl itself.
176
177			=cut
178
179			1;