XMPP2/IM/Connection.pm

package Net::XMPP2::IM::Connection;
use strict;
use Net::XMPP2::Connection;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::IM::Roster;
use Net::XMPP2::IM::Message;
our @ISA = qw/Net::XMPP2::Connection/;

=head1 NAME

Net::XMPP2::IM::Connection - "XML" stream that implements the XMPP RFC 3921.

=head1 SYNOPSIS

   use Net::XMPP2::Connection;

   my $con = Net::XMPP2::Connection->new;

=head1 DESCRIPTION

This module represents a XMPP instant messaging connection and implements
RFC 3921.

This module is a subclass of C<Net::XMPP2::Connection> and inherits all methods.
For example C<reg_cb> and the stanza sending routines.

For additional events that can be registered to look below in the EVENTS section.

=head1 METHODS

=over 4

=item B<new (%args)>

This is the constructor. It takes the same arguments as
the constructor of L<Net::XMPP2::Connection> along with a
few others:

=over 4

=item dont_retrieve_roster => $bool

Set this to a true value if no roster should be requested on connection
establishment. You can retrieve the roster later if you want to
with the C<retrieve_roster> method.

The internal roster will be set even if this option is active, and
even presences will be stored in there, except that the C<get_contacts>
method on the roster object won't return anything as there are
no roster items.

=item initial_presence => $priority

This sets whether the initial presence should be sent. C<$priority>
should be the priority of the initial presence. The default value
for the initial presence C<$priority> is 10.

If you pass a undefined value as C<$priority> no initial presence will
be sent!

=back

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;

   my %args = @_;

   unless (exists $args{initial_presence}) {
      $args{initial_presence} = 10;
   }

   my $self = $class->SUPER::new (%args);

   $self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);

   $self->reg_cb (message_xml =>
      sub { shift @_; $self->handle_message (@_);  });
   $self->reg_cb (presence_xml =>
      sub { shift @_; $self->handle_presence (@_); });
   $self->reg_cb (iq_set_request_xml =>
      sub { shift @_; $self->handle_iq_set (@_);   });
   $self->reg_cb (disconnect =>
      sub { shift @_; $self->handle_disconnect (@_); });

   $self->reg_cb (stream_ready => sub {
      my ($jid) = @_;
      if ($self->features ()->find_all ([qw/session session/])) {
         $self->send_session_iq;
      } else {
         $self->init_connection;
      }
   });

   my $proxy_cb = sub {
      my ($self, $er) = @_;
      $self->event (error => $er);
   };

   $self->reg_cb (
      session_error  => $proxy_cb,
      roster_error   => $proxy_cb,
      presence_error => $proxy_cb,
      message_error  => $proxy_cb,
   );

   $self
}

sub send_session_iq {
   my ($self) = @_;

   $self->send_iq (set => sub {
      my ($w) = @_;
      $w->addPrefix (xmpp_ns ('session'), '');
      $w->emptyTag ([xmpp_ns ('session'), 'session']);

   }, sub {
      my ($node, $error) = @_;
      if ($node) {
         $self->init_connection;
      } else {
         $self->event (session_error => $error);
      }
   });
}

sub init_connection {
   my ($self) = @_;
   if ($self->{dont_retrieve_roster}) {
      $self->initial_presence;
      $self->{session_active} = 1;
      $self->event ('session_ready');

   } else {
      $self->retrieve_roster (sub {
         $self->initial_presence;
         $self->{session_active} = 1;
         $self->event ('session_ready');
      });
   }
}

sub initial_presence {
   my ($self) = @_;
   if (defined $self->{initial_presence}) {
      $self->send_presence (undef, undef, priority => $self->{initial_presence});
   }
   # else do nothing
}

=item B<retrieve_roster ($cb)>

This method initiates a roster request. If you set C<dont_retrieve_roster>
when creating this connection no roster was retrieved.
You can do that with this method. The coderef in C<$cb> will be
called after the roster was retrieved.

The first argument of the callback in C<$cb> will be the roster
and the second will be a L<Net::XMPP2::Error::IQ> object when
an error occured while retrieving the roster.

=cut

sub retrieve_roster {
   my ($self, $cb) = @_;

   $self->send_iq (get => sub {
      my ($w) = @_;
      $w->addPrefix (xmpp_ns ('roster'), '');
      $w->emptyTag ([xmpp_ns ('roster'), 'query']);

   }, sub {
      my ($node, $error) = @_;
      if ($node) {
         $self->{roster}->set_retrieved;
         $self->store_roster ($node);
      } else {
         $self->event (roster_error => $error);
      }

      $cb->($self, $self->{roster}, $error) if $cb
   });
}

sub store_roster {
   my ($self, $node) = @_;
   my @upd = $self->{roster}->update ($node);
   $self->event (roster_update => $self->{roster}, \@upd);
}

=item B<get_roster>

Returns the roster object of type L<Net::XMPP2::IM::Roster>.

=cut

sub get_roster {
   my ($self) = @_;
   $self->{roster}
}

sub handle_iq_set {
   my ($self, $node, $rhandled) = @_;

   if ($node->find_all ([qw/roster query/])) {
      $self->store_roster ($node);
      $self->reply_iq_result ($node);
      $$rhandled = 1
   }
}

sub handle_presence {
   my ($self, $node) = @_;
   if ($node->attr ('type') eq 'error') {
      my $error = Net::XMPP2::Error::Presence->new (node => $node);
      $self->event (presence_error => $error);
      return if $error->type ne 'continue';
   }

   my ($contact, $old, $new) = $self->{roster}->update_presence ($node);
   $self->event (presence_update => $self->{roster}, $contact, $old, $new)
}

sub handle_message {
   my ($self, $node) = @_;

   if ($node->attr ('type') eq 'error') {
      my $error = Net::XMPP2::Error::Message->new (node => $node);
      $self->event (message_error => $error);
      return if $error->type ne 'continue';
   }

   my $from     = $node->attr ('from');
   my $to       = $node->attr ('to');
   my $type     = $node->attr ('type');
   my ($thread) = $node->find_all ([qw/client thread/]);

   my %bodies;
   my %subjects;

   $bodies{$_->attr ('lang') || ''} = $_->text
      for $node->find_all ([qw/client body/]);
   $subjects{$_->attr ('lang') || ''} = $_->text
      for $node->find_all ([qw/client subject/]);

   my $msg =
      Net::XMPP2::IM::Message->new (
         connection => $self,
         from       => $from,
         to         => $to,
         type       => $type,
         bodies     => \%bodies,
         subjects   => \%subjects,
         thread     => $thread
      );

   $self->event (message => $msg);
}

sub handle_disconnect {
   my ($self) = @_;
   delete $self->{roster};
}

=back

=head1 EVENTS

These additional events can be registered on with C<reg_cb>:

In the following events C<$roster> is the L<Net::XMPP2::IM::Roster>
object you get by calling C<get_roster>.

=over 4

=item session_ready

This event is generated when the session has been fully established and
can be used to send around messages and other stuff.

=item session_error => $error

If an error happened during establishment of the session this
event will be generated. C<$error> will be an L<Net::XMPP2::Error::IQ>
error object.

=item roster_update => $roster, $contacts

This event is emitted when a roster update has been received.
C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
which have changed. If a contact was removed it will return 'remove'
when you call the C<subscription> method on it.

The first time this event is sent is when the roster was received
for the first time.

=item roster_error => $error

If an error happened during retrival of the roster this event will
be generated.
C<$error> will be an L<Net::XMPP2::Error::IQ> error object.

=item presence_update => $roster, $contact, $old_presence, $new_presence

This event is emitted when the presence of a contact has changed.
C<$contact> is the L<Net::XMPP2::IM::Contact> object which presence status
has changed.
C<$old_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
presence prior to the change.
C<$new_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
presence after to the change.

=item presence_error => $error

This event is emitted when a presence stanza error was received.
C<$error> will be an L<Net::XMPP2::Error::Presence> error object.

=item message => $msg

This event is emitted when a message was received.
C<$msg> is a L<Net::XMPP2::IM::Message> object.

=item message_error => $error

This event is emitted when a message stanza error was received.
C<$error> will be an L<Net::XMPP2::Error::Message> error object.

=item contact_request_subscribe => $roster, $contact

This event is generated when the C<$contact> wants to subscribe
to your presence.

If any of the event callbacks for this event return a true value then the
subscription request is accepted and a subscribed presence is sent.  If all
callbacks return a false value the subscription request is cancelled.  If none
of the callbacks return anything (all return an empty list) nothing of the
former two things are done.

If you want to accept or decline the request later, call
C<send_subscribed> method of L<Net::XMPP2::IM::Contact> or
C<send_unsubscribed> method of L<Net::XMPP2::IM::Contact> on C<$contact>.

=item contact_subscribed => $roster, $contact

This event is generated when C<$contact> subscribed to your presence successfully.

=item contact_did_unsubscribe => $roster, $contact, $rdoit

This event is generated when C<$contact> unsubscribes from your presence.

Returning a true value from any event callback will also unsubscribe you from
the presence of the contact.

If you want to unsubscribe later from him call the C<send_unsubscribed> method
of L<Net::XMPP2::IM::Contact> on C<$contact>.

=item contact_unsubscribed => $roster, $contact

This event is generated when C<$contact> unsubscribed you from his presence.

=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; # End of Net::XMPP2
Revision:	1.21
Committed:	Tue Jul 24 13:35:22 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.20:	+11 -6 lines
Log Message:	changed subscription semantics
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::IM::Connection;
2			use strict;
3			use Net::XMPP2::Connection;
4			use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	elmex	1.5	use Net::XMPP2::IM::Roster;
6	elmex	1.6	use Net::XMPP2::IM::Message;
7	elmex	1.1	our @ISA = qw/Net::XMPP2::Connection/;
8
9			=head1 NAME
10
11	elmex	1.16	Net::XMPP2::IM::Connection - "XML" stream that implements the XMPP RFC 3921.
12	elmex	1.1
13			=head1 SYNOPSIS
14
15			use Net::XMPP2::Connection;
16
17			my $con = Net::XMPP2::Connection->new;
18
19			=head1 DESCRIPTION
20
21			This module represents a XMPP instant messaging connection and implements
22			RFC 3921.
23
24			This module is a subclass of C<Net::XMPP2::Connection> and inherits all methods.
25			For example C<reg_cb> and the stanza sending routines.
26
27			For additional events that can be registered to look below in the EVENTS section.
28
29			=head1 METHODS
30
31	elmex	1.14	=over 4
32	elmex	1.1
33	elmex	1.14	=item B<new (%args)>
34	elmex	1.7
35			This is the constructor. It takes the same arguments as
36			the constructor of L<Net::XMPP2::Connection> along with a
37			few others:
38
39			=over 4
40
41			=item dont_retrieve_roster => $bool
42
43			Set this to a true value if no roster should be requested on connection
44			establishment. You can retrieve the roster later if you want to
45			with the C<retrieve_roster> method.
46
47			The internal roster will be set even if this option is active, and
48			even presences will be stored in there, except that the C<get_contacts>
49			method on the roster object won't return anything as there are
50			no roster items.
51
52	elmex	1.19	=item initial_presence => $priority
53
54			This sets whether the initial presence should be sent. C<$priority>
55			should be the priority of the initial presence. The default value
56			for the initial presence C<$priority> is 10.
57
58			If you pass a undefined value as C<$priority> no initial presence will
59			be sent!
60
61	elmex	1.7	=back
62
63			=cut
64
65	elmex	1.1	sub new {
66			my $this = shift;
67			my $class = ref($this) \|\| $this;
68	elmex	1.19
69			my %args = @_;
70
71			unless (exists $args{initial_presence}) {
72			$args{initial_presence} = 10;
73			}
74
75			my $self = $class->SUPER::new (%args);
76	elmex	1.2
77	elmex	1.5	$self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);
78	elmex	1.2
79	elmex	1.5	$self->reg_cb (message_xml =>
80	elmex	1.20	sub { shift @_; $self->handle_message (@_); });
81	elmex	1.5	$self->reg_cb (presence_xml =>
82	elmex	1.20	sub { shift @_; $self->handle_presence (@_); });
83	elmex	1.5	$self->reg_cb (iq_set_request_xml =>
84	elmex	1.20	sub { shift @_; $self->handle_iq_set (@_); });
85	elmex	1.5	$self->reg_cb (disconnect =>
86	elmex	1.20	sub { shift @_; $self->handle_disconnect (@_); });
87	elmex	1.2
88	elmex	1.1	$self->reg_cb (stream_ready => sub {
89			my ($jid) = @_;
90	elmex	1.2	if ($self->features ()->find_all ([qw/session session/])) {
91			$self->send_session_iq;
92			} else {
93	elmex	1.7	$self->init_connection;
94	elmex	1.2	}
95	elmex	1.1	});
96	elmex	1.18
97			my $proxy_cb = sub {
98			my ($self, $er) = @_;
99			$self->event (error => $er);
100			};
101
102			$self->reg_cb (
103			session_error => $proxy_cb,
104			roster_error => $proxy_cb,
105			presence_error => $proxy_cb,
106			message_error => $proxy_cb,
107			);
108
109	elmex	1.1	$self
110			}
111
112	elmex	1.2	sub send_session_iq {
113			my ($self) = @_;
114
115			$self->send_iq (set => sub {
116			my ($w) = @_;
117			$w->addPrefix (xmpp_ns ('session'), '');
118			$w->emptyTag ([xmpp_ns ('session'), 'session']);
119
120			}, sub {
121	elmex	1.9	my ($node, $error) = @_;
122	elmex	1.2	if ($node) {
123	elmex	1.7	$self->init_connection;
124	elmex	1.2	} else {
125	elmex	1.14	$self->event (session_error => $error);
126	elmex	1.2	}
127			});
128			}
129
130	elmex	1.7	sub init_connection {
131			my ($self) = @_;
132			if ($self->{dont_retrieve_roster}) {
133	elmex	1.19	$self->initial_presence;
134			$self->{session_active} = 1;
135			$self->event ('session_ready');
136
137	elmex	1.7	} else {
138	elmex	1.19	$self->retrieve_roster (sub {
139			$self->initial_presence;
140			$self->{session_active} = 1;
141			$self->event ('session_ready');
142			});
143			}
144			}
145
146			sub initial_presence {
147			my ($self) = @_;
148			if (defined $self->{initial_presence}) {
149			$self->send_presence (undef, undef, priority => $self->{initial_presence});
150	elmex	1.7	}
151	elmex	1.19	# else do nothing
152	elmex	1.7	}
153
154	elmex	1.14	=item B<retrieve_roster ($cb)>
155	elmex	1.9
156			This method initiates a roster request. If you set C<dont_retrieve_roster>
157			when creating this connection no roster was retrieved.
158			You can do that with this method. The coderef in C<$cb> will be
159			called after the roster was retrieved.
160
161			The first argument of the callback in C<$cb> will be the roster
162			and the second will be a L<Net::XMPP2::Error::IQ> object when
163			an error occured while retrieving the roster.
164
165			=cut
166
167	elmex	1.3	sub retrieve_roster {
168	elmex	1.9	my ($self, $cb) = @_;
169	elmex	1.4
170	elmex	1.3	$self->send_iq (get => sub {
171			my ($w) = @_;
172			$w->addPrefix (xmpp_ns ('roster'), '');
173			$w->emptyTag ([xmpp_ns ('roster'), 'query']);
174	elmex	1.4
175	elmex	1.3	}, sub {
176	elmex	1.9	my ($node, $error) = @_;
177	elmex	1.3	if ($node) {
178	elmex	1.14	$self->{roster}->set_retrieved;
179	elmex	1.3	$self->store_roster ($node);
180			} else {
181	elmex	1.9	$self->event (roster_error => $error);
182	elmex	1.3	}
183	elmex	1.7
184	elmex	1.9	$cb->($self, $self->{roster}, $error) if $cb
185	elmex	1.3	});
186			}
187
188			sub store_roster {
189			my ($self, $node) = @_;
190	elmex	1.9	my @upd = $self->{roster}->update ($node);
191	elmex	1.8	$self->event (roster_update => $self->{roster}, \@upd);
192	elmex	1.5	}
193
194	elmex	1.14	=item B<get_roster>
195
196			Returns the roster object of type L<Net::XMPP2::IM::Roster>.
197
198			=cut
199
200	elmex	1.5	sub get_roster {
201			my ($self) = @_;
202			$self->{roster}
203			}
204
205			sub handle_iq_set {
206			my ($self, $node, $rhandled) = @_;
207
208			if ($node->find_all ([qw/roster query/])) {
209			$self->store_roster ($node);
210	elmex	1.9	$self->reply_iq_result ($node);
211			$$rhandled = 1
212	elmex	1.5	}
213	elmex	1.3	}
214
215	elmex	1.2	sub handle_presence {
216	elmex	1.5	my ($self, $node) = @_;
217	elmex	1.13	if ($node->attr ('type') eq 'error') {
218			my $error = Net::XMPP2::Error::Presence->new (node => $node);
219			$self->event (presence_error => $error);
220			return if $error->type ne 'continue';
221			}
222
223	elmex	1.9	my ($contact, $old, $new) = $self->{roster}->update_presence ($node);
224			$self->event (presence_update => $self->{roster}, $contact, $old, $new)
225	elmex	1.2	}
226
227			sub handle_message {
228	elmex	1.6	my ($self, $node) = @_;
229
230	elmex	1.13	if ($node->attr ('type') eq 'error') {
231			my $error = Net::XMPP2::Error::Message->new (node => $node);
232			$self->event (message_error => $error);
233			return if $error->type ne 'continue';
234			}
235
236	elmex	1.6	my $from = $node->attr ('from');
237			my $to = $node->attr ('to');
238			my $type = $node->attr ('type');
239			my ($thread) = $node->find_all ([qw/client thread/]);
240
241			my %bodies;
242			my %subjects;
243
244			$bodies{$_->attr ('lang') \|\| ''} = $_->text
245			for $node->find_all ([qw/client body/]);
246			$subjects{$_->attr ('lang') \|\| ''} = $_->text
247			for $node->find_all ([qw/client subject/]);
248
249			my $msg =
250			Net::XMPP2::IM::Message->new (
251			connection => $self,
252			from => $from,
253			to => $to,
254			type => $type,
255			bodies => \%bodies,
256			subjects => \%subjects,
257			thread => $thread
258			);
259
260			$self->event (message => $msg);
261	elmex	1.2	}
262
263	elmex	1.5	sub handle_disconnect {
264			my ($self) = @_;
265			delete $self->{roster};
266			}
267
268	elmex	1.14	=back
269
270	elmex	1.1	=head1 EVENTS
271
272			These additional events can be registered on with C<reg_cb>:
273
274	elmex	1.12	In the following events C<$roster> is the L<Net::XMPP2::IM::Roster>
275			object you get by calling C<get_roster>.
276
277	elmex	1.1	=over 4
278
279			=item session_ready
280
281	elmex	1.2	This event is generated when the session has been fully established and
282			can be used to send around messages and other stuff.
283
284	elmex	1.9	=item session_error => $error
285	elmex	1.2
286			If an error happened during establishment of the session this
287	elmex	1.9	event will be generated. C<$error> will be an L<Net::XMPP2::Error::IQ>
288			error object.
289	elmex	1.1
290	elmex	1.8	=item roster_update => $roster, $contacts
291
292			This event is emitted when a roster update has been received.
293			C<$contacts> is an array reference of L<Net::XMPP2::IM::Contact> objects
294	elmex	1.9	which have changed. If a contact was removed it will return 'remove'
295			when you call the C<subscription> method on it.
296
297	elmex	1.10	The first time this event is sent is when the roster was received
298			for the first time.
299
300	elmex	1.9	=item roster_error => $error
301
302			If an error happened during retrival of the roster this event will
303			be generated.
304			C<$error> will be an L<Net::XMPP2::Error::IQ> error object.
305	elmex	1.8
306			=item presence_update => $roster, $contact, $old_presence, $new_presence
307
308			This event is emitted when the presence of a contact has changed.
309			C<$contact> is the L<Net::XMPP2::IM::Contact> object which presence status
310			has changed.
311			C<$old_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
312			presence prior to the change.
313			C<$new_presence> is a L<Net::XMPP2::IM::Presence> object which represents the
314			presence after to the change.
315
316	elmex	1.13	=item presence_error => $error
317
318			This event is emitted when a presence stanza error was received.
319			C<$error> will be an L<Net::XMPP2::Error::Presence> error object.
320
321	elmex	1.8	=item message => $msg
322
323			This event is emitted when a message was received.
324			C<$msg> is a L<Net::XMPP2::IM::Message> object.
325
326	elmex	1.13	=item message_error => $error
327
328			This event is emitted when a message stanza error was received.
329			C<$error> will be an L<Net::XMPP2::Error::Message> error object.
330
331	elmex	1.21	=item contact_request_subscribe => $roster, $contact
332	elmex	1.12
333			This event is generated when the C<$contact> wants to subscribe
334	elmex	1.21	to your presence.
335
336			If any of the event callbacks for this event return a true value then the
337			subscription request is accepted and a subscribed presence is sent. If all
338			callbacks return a false value the subscription request is cancelled. If none
339			of the callbacks return anything (all return an empty list) nothing of the
340			former two things are done.
341	elmex	1.12
342	elmex	1.15	If you want to accept or decline the request later, call
343			C<send_subscribed> method of L<Net::XMPP2::IM::Contact> or
344			C<send_unsubscribed> method of L<Net::XMPP2::IM::Contact> on C<$contact>.
345	elmex	1.12
346			=item contact_subscribed => $roster, $contact
347
348			This event is generated when C<$contact> subscribed to your presence successfully.
349
350			=item contact_did_unsubscribe => $roster, $contact, $rdoit
351
352			This event is generated when C<$contact> unsubscribes from your presence.
353	elmex	1.21
354			Returning a true value from any event callback will also unsubscribe you from
355			the presence of the contact.
356	elmex	1.12
357	elmex	1.17	If you want to unsubscribe later from him call the C<send_unsubscribed> method
358			of L<Net::XMPP2::IM::Contact> on C<$contact>.
359	elmex	1.12
360			=item contact_unsubscribed => $roster, $contact
361
362			This event is generated when C<$contact> unsubscribed you from his presence.
363
364	elmex	1.1	=back
365
366			=head1 AUTHOR
367
368	elmex	1.14	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
369	elmex	1.1
370			=head1 COPYRIGHT & LICENSE
371
372			Copyright 2007 Robin Redeker, all rights reserved.
373
374			This program is free software; you can redistribute it and/or modify it
375			under the same terms as Perl itself.
376
377			=cut
378
379			1; # End of Net::XMPP2