Net/XMPP2/Event.pm

package Net::XMPP2::Event;

=head1 NAME

Net::XMPP2::Event - A 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.

=head2 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}
}

=head2 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}};
   }
}


=head2 event ($eventname, @args)

Emits the event C<$eventname> and passes the arguments C<@args>.

=cut

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

   my $nxt = [];

   my $handled;
   for (@{$self->{events}->{lc $ev}}) {
      $_->[1]->($self, @arg) and push @$nxt, $_;
   }

   for (values %{$self->{event_forwards}}) {
      $_->[1]->($self, $_->[0], $ev, @arg);
   }

   $self->{events}->{lc $ev} = $nxt;
}

=head2 add_forward ($obj, $forward_cb)

This method allows to forward or copy all events to a object.
C<$forward_cb> will be called everytime a 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];
}

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.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.3
Committed:	Sun Jun 24 10:41:58 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.2:	+20 -0 lines
Log Message:	finished subscription implementation and also added the possibility of forwarding all events of an object to some other object and forwarded all events from a IM::Connection to the Client.
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Event;
2
3			=head1 NAME
4
5			Net::XMPP2::Event - A event handler class
6
7			=head1 SYNOPSIS
8
9			package foo;
10			use Net::XMPP2::Event;
11
12			our @ISA = qw/Net::XMPP2::Event/;
13
14			package main;
15			my $o = foo->new;
16			$o->reg_cb (foo => sub { ...; 1 });
17			$o->event (foo => 1, 2, 3);
18
19			=head1 DESCRIPTION
20
21			This module is just a small helper module for the connection
22			and client classes.
23
24			You may only derive from this package.
25
26			=head2 reg_cb ($eventname1, $cb1, [$eventname2, $cb2, ...])
27
28			This method registers a callback C<$cb1> for the event with the
29			name C<$eventname1>. You can also pass multiple of these eventname => callback
30			pairs.
31
32	elmex	1.2	The return value will be an ID that represents the set of callbacks you have installed.
33			Call C<unreg_cb> with that ID to remove those callbacks again.
34
35	elmex	1.1	To see a documentation of emitted events please take a look at the EVENTS section
36	elmex	1.2	in the classes that inherit from this one.
37	elmex	1.1
38			=cut
39
40			sub reg_cb {
41			my ($self, %regs) = @_;
42
43	elmex	1.2	$self->{id}++;
44
45	elmex	1.1	for my $cmd (keys %regs) {
46	elmex	1.2	push @{$self->{events}->{lc $cmd}}, [$self->{id}, $regs{$cmd}]
47	elmex	1.1	}
48
49	elmex	1.2	$self->{id}
50			}
51
52			=head2 unreg_cb ($id)
53
54			Removes the set C<$id> of registered callbacks. C<$id> is the
55			return value of a C<reg_cb> call.
56
57			=cut
58
59			sub unreg_cb {
60			my ($self, $id) = @_;
61
62			my $set = delete $self->{ids}->{$id};
63
64			for my $key (keys %{$self->{events}}) {
65			@{$self->{events}->{$key}} =
66			grep {
67			$_->[0] ne $id
68			} @{$self->{events}->{$key}};
69			}
70	elmex	1.1	}
71
72	elmex	1.2
73	elmex	1.1	=head2 event ($eventname, @args)
74
75			Emits the event C<$eventname> and passes the arguments C<@args>.
76
77			=cut
78
79			sub event {
80			my ($self, $ev, @arg) = @_;
81
82			my $nxt = [];
83
84			my $handled;
85			for (@{$self->{events}->{lc $ev}}) {
86	elmex	1.2	$_->[1]->($self, @arg) and push @$nxt, $_;
87	elmex	1.1	}
88
89	elmex	1.3	for (values %{$self->{event_forwards}}) {
90			$_->[1]->($self, $_->[0], $ev, @arg);
91			}
92
93	elmex	1.1	$self->{events}->{lc $ev} = $nxt;
94			}
95
96	elmex	1.3	=head2 add_forward ($obj, $forward_cb)
97
98			This method allows to forward or copy all events to a object.
99			C<$forward_cb> will be called everytime a event is generated in C<$self>.
100			The first argument to the callback C<$forward_cb> will be <$self>, the second
101			will be C<$obj>, the third will be the event name and the rest will be
102			the event arguments. (For third and rest of argument also see description
103			of C<event>).
104
105			=cut
106
107			sub add_forward {
108			my ($self, $obj, $forward_cb) = @_;
109			$self->{event_forwards}->{$obj} = [$obj, $forward_cb];
110			}
111
112	elmex	1.1	=head1 AUTHOR
113
114			Robin Redeker, C<< <elmex at ta-sa.org> >>
115
116			=head1 COPYRIGHT & LICENSE
117
118			Copyright 2007 Robin Redeker, all rights reserved.
119
120			This program is free software; you can redistribute it and/or modify it
121			under the same terms as Perl itself.
122
123			=cut
124
125			1;